From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Kelly Dean Newsgroups: gmane.emacs.devel Subject: [PATCH] (Updated) Run hook when variable is set Date: Thu, 05 Feb 2015 03:10:57 +0000 Message-ID: References: NNTP-Posting-Host: plane.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: ger.gmane.org 1423105968 30683 80.91.229.3 (5 Feb 2015 03:12:48 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Thu, 5 Feb 2015 03:12:48 +0000 (UTC) Cc: emacs-devel@gnu.org To: Stefan Monnier Original-X-From: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Thu Feb 05 04:12:48 2015 Return-path: Envelope-to: ged-emacs-devel@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by plane.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1YJCs1-0003gH-Aa for ged-emacs-devel@m.gmane.org; Thu, 05 Feb 2015 04:12:45 +0100 Original-Received: from localhost ([::1]:39788 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1YJCs0-0002sS-Gj for ged-emacs-devel@m.gmane.org; Wed, 04 Feb 2015 22:12:44 -0500 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:56913) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1YJCrw-0002sC-3w for emacs-devel@gnu.org; Wed, 04 Feb 2015 22:12:42 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1YJCrr-00023R-WB for emacs-devel@gnu.org; Wed, 04 Feb 2015 22:12:40 -0500 Original-Received: from relay6-d.mail.gandi.net ([2001:4b98:c:538::198]:50280) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1YJCrr-00023J-ME for emacs-devel@gnu.org; Wed, 04 Feb 2015 22:12:35 -0500 Original-Received: from mfilter23-d.gandi.net (mfilter23-d.gandi.net [217.70.178.151]) by relay6-d.mail.gandi.net (Postfix) with ESMTP id 02E94FB88B; Thu, 5 Feb 2015 04:12:35 +0100 (CET) X-Virus-Scanned: Debian amavisd-new at mfilter23-d.gandi.net Original-Received: from relay6-d.mail.gandi.net ([217.70.183.198]) by mfilter23-d.gandi.net (mfilter23-d.gandi.net [10.0.15.180]) (amavisd-new, port 10024) with ESMTP id s+412WIluEIx; Thu, 5 Feb 2015 04:12:32 +0100 (CET) X-Originating-IP: 66.220.3.179 Original-Received: from localhost (gm179.geneticmail.com [66.220.3.179]) (Authenticated sender: kelly@prtime.org) by relay6-d.mail.gandi.net (Postfix) with ESMTPSA id 65696FB8A4; Thu, 5 Feb 2015 04:12:15 +0100 (CET) In-Reply-To: X-detected-operating-system: by eggs.gnu.org: Error: Malformed IPv6 address (bad octet value). X-Received-From: 2001:4b98:c:538::198 X-BeenThere: emacs-devel@gnu.org X-Mailman-Version: 2.1.14 Precedence: list List-Id: "Emacs development discussions." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Original-Sender: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.emacs.devel:182422 Archived-At: --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable Updated patch attached. Now designed only for debugging and profiling. Ap= plies to trunk. Changes: It now uses a single centralized hook, rather than one per symbol. It passes the new value as an argument, rather than passing only the symb= ol and environment. The speed (for both hooked and unhooked symbols) is unaffected by propert= y lists. Unhooked symbols are immediately skipped. It still passes the environment, since it's useful during debugging to no= tice when your setq is accidentally setting a buffer-local variable that = you thought didn't exist, or setting a global that you thought had been m= ade buffer-local, or setting a dynamic local because some other code (tha= t called your code) let-bound a symbol that you thought you were setting = globally. Also, if you do: (let ((foo 'bar)) (setq-default foo 'baz)) then varhook now intentionally reports env as =E2=8C=9Cinvalid=E2=8C=9D (= but the behavior of the code is not changed). If that's actually a valid = thing to do, then I'll change how it's reported. I'm unclear on your reason for extending the =C2=ABconstant=C2=BB field t= o include the =C2=ABhooked=C2=BB bit, rather than giving the latter its o= wn name. Either way, a new bit is needed (I can't fit the meaning of =C2=AB= hooked=C2=BB into =C2=ABconstant=C2=BB's current two bits), and either wa= y, the size of a symbol remains unchanged: 24 bytes on 32-bit platforms, = and 48 bytes on 64-bits. The bit field now has 21 and 53 remaining unused= bits, respectively, after =C2=ABhooked=C2=BB is added. Example usage: (setq syms-to-watch '(foo bar poo par goo gar)) (setq syms-to-pause-on '(poo par)) (setq sym-profiles '((foo 0) (bar 0) (goo 0) (gar 0))) (setq nonglobals-to-barf-on '(goo gar)) ; Supposed to be set only globall= y (defun tattle (sym env val) (if (boundp sym) (message "Symbol %S modified in env %S. New value: %S" sym env val) (message "Symbol %S unbound in env %S" sym env))) (defun pause (sym _env _val) (if (memq sym syms-to-pause-on) (unless (y-or-n-p "Continue? ") (keyboard-quit)))) (defun profile (sym _env _val) (let ((p (assq sym sym-profiles))) (if p (incf (cadr p))))) (defun barf-nonglobal (sym env _val) (and (not (eq env 'global)) (memq sym nonglobals-to-barf-on) (debug))) (add-hook 'varhook #'tattle) ; There's only one hook, used for all symbol= s (add-hook 'varhook #'pause t) (add-hook 'varhook #'profile) (add-hook 'varhook #'barf-nonglobal t) (mapc #'hook syms-to-watch) ;; Open *Messages* in another window, then do your debugging... (mapc #'unhook syms-to-watch) ; When you're done. (cl-loop for s being the symbols ; Check if anything is still hooked with hooked =3D nil finally return hooked do (if (hookedp s) (push s hooked))) --=-=-= Content-Type: text/x-diff Content-Disposition: inline; filename=varhook-single.patch --- src/lisp.h +++ src/lisp.h @@ -1613,6 +1613,9 @@ /* True if pointed to from purespace and hence can't be GC'd. */ bool_bf pinned : 1; + /* True means that setting this symbol will run varhook. */ + bool_bf hooked : 1; + /* The symbol's name, as a Lisp string. */ Lisp_Object name; @@ -3391,6 +3394,14 @@ EXFUN (Fbyteorder, 0) ATTRIBUTE_CONST; /* Defined in data.c. */ +typedef enum + { + Dyn_Unbind = -1, + Dyn_Current = 0, + Dyn_Bind = 1, + Dyn_Skip = 2, + Dyn_Global = 3 + } Dyn_Bind_Direction; extern Lisp_Object indirect_function (Lisp_Object); extern Lisp_Object find_symbol_value (Lisp_Object); enum Arith_Comparison { @@ -3438,10 +3449,23 @@ Lisp_Object); extern _Noreturn Lisp_Object wrong_type_argument (Lisp_Object, Lisp_Object); extern Lisp_Object do_symval_forwarding (union Lisp_Fwd *); +extern void run_varhook (struct Lisp_Symbol*, bool, Dyn_Bind_Direction, Lisp_Object); extern void set_internal (Lisp_Object, Lisp_Object, Lisp_Object, bool); +extern void set_internal_1 (Lisp_Object, Lisp_Object, Lisp_Object, bool, + Dyn_Bind_Direction); +extern void set_default_internal (Lisp_Object, Lisp_Object, + Dyn_Bind_Direction); extern void syms_of_data (void); extern void swap_in_global_binding (struct Lisp_Symbol *); +INLINE void +try_run_varhook (struct Lisp_Symbol* sym, bool buf_local, + Dyn_Bind_Direction dir, Lisp_Object value) +{ + if (sym->hooked) + run_varhook (sym, buf_local, dir, value); +} + /* Defined in cmds.c */ extern void syms_of_cmds (void); extern void keys_of_cmds (void); @@ -3905,9 +3929,9 @@ should no longer be used. */ extern Lisp_Object Vrun_hooks; extern void run_hook_with_args_2 (Lisp_Object, Lisp_Object, Lisp_Object); -extern Lisp_Object run_hook_with_args (ptrdiff_t nargs, Lisp_Object *args, - Lisp_Object (*funcall) - (ptrdiff_t nargs, Lisp_Object *args)); +extern Lisp_Object run_hook_with_args (ptrdiff_t, Lisp_Object *, + Lisp_Object (*) (ptrdiff_t, Lisp_Object *)); +extern Lisp_Object funcall_nil (ptrdiff_t, Lisp_Object *); extern _Noreturn void xsignal (Lisp_Object, Lisp_Object); extern _Noreturn void xsignal0 (Lisp_Object); extern _Noreturn void xsignal1 (Lisp_Object, Lisp_Object); --- src/eval.c +++ src/eval.c @@ -2357,7 +2357,7 @@ /* Run hook variables in various ways. */ -static Lisp_Object +Lisp_Object funcall_nil (ptrdiff_t nargs, Lisp_Object *args) { Ffuncall (nargs, args); @@ -3142,9 +3142,12 @@ specpdl_ptr->let.old_value = SYMBOL_VAL (sym); grow_specpdl (); if (!sym->constant) - SET_SYMBOL_VAL (sym, value); + { + SET_SYMBOL_VAL (sym, value); + try_run_varhook (sym, false, Dyn_Bind, value); + } else - set_internal (symbol, value, Qnil, 1); + set_internal_1 (symbol, value, Qnil, 1, Dyn_Bind); break; case SYMBOL_LOCALIZED: if (SYMBOL_BLV (sym)->frame_local) @@ -3176,7 +3179,7 @@ { specpdl_ptr->let.kind = SPECPDL_LET_DEFAULT; grow_specpdl (); - Fset_default (symbol, value); + set_default_internal (symbol, value, Dyn_Bind); return; } } @@ -3184,7 +3187,7 @@ specpdl_ptr->let.kind = SPECPDL_LET; grow_specpdl (); - set_internal (symbol, value, Qnil, 1); + set_internal_1 (symbol, value, Qnil, 1, Dyn_Bind); break; } default: emacs_abort (); @@ -3319,7 +3322,9 @@ struct Lisp_Symbol *sym = XSYMBOL (specpdl_symbol (specpdl_ptr)); if (sym->redirect == SYMBOL_PLAINVAL) { - SET_SYMBOL_VAL (sym, specpdl_old_value (specpdl_ptr)); + Lisp_Object oldval = specpdl_old_value (specpdl_ptr); + SET_SYMBOL_VAL (sym, oldval); + try_run_varhook (sym, false, Dyn_Unbind, oldval); break; } else @@ -3329,8 +3334,8 @@ } } case SPECPDL_LET_DEFAULT: - Fset_default (specpdl_symbol (specpdl_ptr), - specpdl_old_value (specpdl_ptr)); + set_default_internal (specpdl_symbol (specpdl_ptr), + specpdl_old_value (specpdl_ptr), Dyn_Unbind); break; case SPECPDL_LET_LOCAL: { @@ -3342,7 +3347,7 @@ /* 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_1 (symbol, old_value, where, 1, Dyn_Unbind); } break; } @@ -3537,7 +3542,7 @@ Lisp_Object sym = specpdl_symbol (tmp); Lisp_Object old_value = specpdl_old_value (tmp); set_specpdl_old_value (tmp, Fdefault_value (sym)); - Fset_default (sym, old_value); + set_default_internal (sym, old_value, Dyn_Skip); } break; case SPECPDL_LET_LOCAL: @@ -3553,7 +3558,7 @@ { set_specpdl_old_value (tmp, Fbuffer_local_value (symbol, where)); - set_internal (symbol, old_value, where, 1); + set_internal_1 (symbol, old_value, where, 1, Dyn_Skip); } } break; @@ -3828,6 +3833,14 @@ still determine whether to handle the particular condition. */); Vdebug_on_signal = Qnil; + DEFVAR_LISP ("varhook", Vvarhook, + doc: /* This is the hook run when hooked symbols are set. +The following arguments are passed: +The symbol that was set. +The environment in which it was set. +The new value. */); + Vvarhook = Qnil; + /* When lexical binding is being used, Vinternal_interpreter_environment is non-nil, and contains an alist of lexically-bound variable, or (t), indicating an empty --- src/data.c +++ src/data.c @@ -612,6 +613,15 @@ /* Extract and set components of symbols. */ +DEFUN ("hookedp", Fhookedp, Shookedp, 1, 1, 0, + doc: /* Return t if SYMBOL is hooked. +When hooked, setting SYMBOL will run `varhook'. */) + (register Lisp_Object symbol) +{ + CHECK_SYMBOL (symbol); + return XSYMBOL (symbol)->hooked ? Qt : Qnil; +} + DEFUN ("boundp", Fboundp, Sboundp, 1, 1, 0, doc: /* Return t if SYMBOL's value is not void. Note that if `lexical-binding' is in effect, this refers to the @@ -661,6 +671,26 @@ return NILP (XSYMBOL (symbol)->function) ? Qnil : Qt; } +DEFUN ("hook", Fhook, Shook, 1, 1, 0, + doc: /* Hook SYMBOL. When hooked, setting it will run `varhook'. +Return SYMBOL. */) + (register Lisp_Object symbol) +{ + CHECK_SYMBOL (symbol); + XSYMBOL (symbol)->hooked = true; + return symbol; +} + +DEFUN ("unhook", Funhook, Sunhook, 1, 1, 0, + doc: /* Unhook SYMBOL. When unhooked, setting it will not run `varhook'. +Return SYMBOL. */) + (register Lisp_Object symbol) +{ + CHECK_SYMBOL (symbol); + XSYMBOL (symbol)->hooked = false; + return symbol; +} + DEFUN ("makunbound", Fmakunbound, Smakunbound, 1, 1, 0, doc: /* Make SYMBOL's value be void. Return SYMBOL. */) @@ -1167,6 +1197,48 @@ xsignal1 (Qvoid_variable, symbol); } +/* For the symbol S that was just set, run varhook. + To the functions on the hook, pass S as the first argument. As the second + argument, pass a symbol indicating the environment in which S was set. + As the third argument, pass the value to which S was set. */ + +void +run_varhook (struct Lisp_Symbol* sym, bool buf_local, Dyn_Bind_Direction dir, + Lisp_Object value) +{ + Lisp_Object hook_and_args[4]; + if (dir == Dyn_Skip) /* From backtrace_eval_unrewind */ + return; + hook_and_args[0] = Qvarhook; + XSETSYMBOL (hook_and_args[1], sym); + switch (dir) + { + case Dyn_Current: + { + bool shadowed; + if (buf_local) + shadowed = let_shadows_buffer_binding_p (sym); + else shadowed = let_shadows_global_binding_p (hook_and_args[1]); + if (shadowed) hook_and_args[2] = Qdyn_local; + else if (buf_local) hook_and_args[2] = Qbuf_local; + else hook_and_args[2] = Qglobal; + break; + } + case Dyn_Global: + { + if (let_shadows_global_binding_p (hook_and_args[1])) + hook_and_args[2] = Qinvalid; + else hook_and_args[2] = Qglobal; + break; + } + case Dyn_Bind: hook_and_args[2] = Qdyn_bind; break; + case Dyn_Unbind: hook_and_args[2] = Qdyn_unbind; break; + default: emacs_abort (); + } + hook_and_args[3] = value; + run_hook_with_args (4, hook_and_args, funcall_nil); +} + DEFUN ("set", Fset, Sset, 2, 2, 0, doc: /* Set SYMBOL's value to NEWVAL, and return NEWVAL. */) (register Lisp_Object symbol, Lisp_Object newval) @@ -1187,6 +1259,21 @@ set_internal (Lisp_Object symbol, Lisp_Object newval, Lisp_Object where, bool bindflag) { + set_internal_1 (symbol, newval, where, bindflag, Dyn_Current); +} + +/* Like set_internal but with direction argument to indicate whether this + function call is due to a binding (1), an unbinding (-1), or neither (0). + As special cases, a value of 2 is a flag to disable run_varhook so that + varhooks aren't run during backtraces, and a value of 3 is a flag + indicating that this function call is due to set_default, which allows + run_varhook to distinguish beween the global and the dyn-local binding. +*/ + +void +set_internal_1 (Lisp_Object symbol, Lisp_Object newval, Lisp_Object where, + bool bindflag, Dyn_Bind_Direction dir) +{ bool voide = EQ (newval, Qunbound); struct Lisp_Symbol *sym; Lisp_Object tem1; @@ -1212,9 +1299,15 @@ switch (sym->redirect) { case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start; - case SYMBOL_PLAINVAL: SET_SYMBOL_VAL (sym , newval); return; + case SYMBOL_PLAINVAL: + { + SET_SYMBOL_VAL (sym, newval); + try_run_varhook (sym, false, dir, newval); + return; + } case SYMBOL_LOCALIZED: { + bool buf_local = true; struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym); if (NILP (where)) { @@ -1258,6 +1351,7 @@ indicating that we're seeing the default value. Likewise if the variable has been let-bound in the current buffer. */ + buf_local = false; if (bindflag || !blv->local_if_set || let_shadows_buffer_binding_p (sym)) { @@ -1299,6 +1393,7 @@ BUFFERP (where) ? XBUFFER (where) : current_buffer); } + try_run_varhook (sym, buf_local, dir, newval); break; } case SYMBOL_FORWARDED: @@ -1324,6 +1419,9 @@ } else store_symval_forwarding (/* sym, */ innercontents, newval, buf); + try_run_varhook (sym, + (XFWDTYPE (innercontents))==Lisp_Fwd_Buffer_Obj, + dir, newval); break; } default: emacs_abort (); @@ -1413,6 +1511,17 @@ for this variable. */) (Lisp_Object symbol, Lisp_Object value) { + set_default_internal (symbol, value, Dyn_Global); + return value; +} + +/* Like Fset_default, but with direction argument. See set_internal_1 for + a description of this argument. */ + +void +set_default_internal (Lisp_Object symbol, Lisp_Object value, + Dyn_Bind_Direction dir) +{ struct Lisp_Symbol *sym; CHECK_SYMBOL (symbol); @@ -1423,7 +1532,7 @@ xsignal1 (Qsetting_constant, symbol); else /* Allow setting keywords to their own value. */ - return value; + return; } sym = XSYMBOL (symbol); @@ -1431,7 +1540,11 @@ switch (sym->redirect) { case SYMBOL_VARALIAS: sym = indirect_variable (sym); goto start; - case SYMBOL_PLAINVAL: return Fset (symbol, value); + case SYMBOL_PLAINVAL: + { + set_internal_1 (symbol, value, Qnil, false, dir); + return; + } case SYMBOL_LOCALIZED: { struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym); @@ -1442,7 +1555,8 @@ /* If the default binding is now loaded, set the REALVALUE slot too. */ if (blv->fwd && EQ (blv->defcell, blv->valcell)) store_symval_forwarding (blv->fwd, value, NULL); - return value; + try_run_varhook (sym, false, dir, value); + return; } case SYMBOL_FORWARDED: { @@ -1468,10 +1582,14 @@ if (!PER_BUFFER_VALUE_P (b, idx)) set_per_buffer_value (b, offset, value); } - return value; + try_run_varhook (sym, false, dir, value); + return; } else - return Fset (symbol, value); + { + set_internal_1 (symbol, value, Qnil, false, dir); + return; + } } default: emacs_abort (); } @@ -3470,6 +3588,14 @@ DEFSYM (Qad_advice_info, "ad-advice-info"); DEFSYM (Qad_activate_internal, "ad-activate-internal"); + DEFSYM (Qvarhook, "varhook"); + DEFSYM (Qglobal, "global"); + DEFSYM (Qbuf_local, "buf-local"); + DEFSYM (Qdyn_local, "dyn-local"); + DEFSYM (Qdyn_bind, "dyn-bind"); + DEFSYM (Qdyn_unbind, "dyn-unbind"); + DEFSYM (Qinvalid, "invalid"); + error_tail = pure_cons (Qerror, Qnil); /* ERROR is used as a signaler for random errors for which nothing else is @@ -3609,8 +3735,11 @@ defsubr (&Sindirect_function); defsubr (&Ssymbol_plist); defsubr (&Ssymbol_name); + defsubr (&Shook); + defsubr (&Sunhook); defsubr (&Smakunbound); defsubr (&Sfmakunbound); + defsubr (&Shookedp); defsubr (&Sboundp); defsubr (&Sfboundp); defsubr (&Sfset); --- src/alloc.c +++ src/alloc.c @@ -3392,4 +3392,5 @@ p->interned = SYMBOL_UNINTERNED; p->constant = 0; + p->hooked = false; p->declared_special = false; p->pinned = false; --=-=-=--