[PATCH] (Updated) Run hook when variable is set

[Kelly Dean <kelly@prtime.org>]

[-- Attachment #1: Type: text/plain, Size: 2747 bytes --]

Updated patch attached. Now designed only for debugging and profiling. Applies 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 symbol and environment.
The speed (for both hooked and unhooked symbols) is unaffected by property lists.
Unhooked symbols are immediately skipped.

It still passes the environment, since it's useful during debugging to notice 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 made buffer-local, or setting a dynamic local because some other code (that 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 ⌜invalid⌝ (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 «constant» field to include the «hooked» bit, rather than giving the latter its own name. Either way, a new bit is needed (I can't fit the meaning of «hooked» into «constant»'s current two bits), and either way, 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 «hooked» 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 globally

(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 symbols
(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 = nil finally return hooked
	 do (if (hookedp s) (push s hooked)))



[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: varhook-single.patch --]
[-- Type: text/x-diff, Size: 13081 bytes --]

--- 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 @@
 \f
 /* 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 @@
 \f
 /* 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;