[PATCH] Run hook when variable is set

[Kelly Dean <kelly@prtime.org>]

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

Emacs lets you hook a mode, so you can run some function(s) whenever the mode is turned on or off.

The patch attached below lets you hook a symbol too, so you can run some function(s) whenever the global or buffer-local variable by that name is set, or a dynamic variable by that name is bound, set, or unbound.

It works for the entire family of Elisp «set» functions (and makunbound), in both Elisp and C. It also works for dynamic-let bindings. It is not implemented for lexical-let bindings.

The purpose of this new feature is to enable a proper fix for bug #19068, and to enable a solution to Stefan's requirement that dynamic-cursor-mode be enabled by default as a condition for adding the latter to Emacs.

Use it like this:
(defun tattle (sym env)
  (message "Symbol %S modified in env %S. New value: %S"
	   sym env (if (boundp sym) (symbol-value sym) 'none)))
(add-hook 'foo-varhook #'tattle)
(put 'foo 'varhook 'foo-varhook) ; The varhook property is the trigger

(setq foo 'bar) → ⌜Symbol foo modified in env global. New value: bar⌝

(setq lexical-binding nil)
(let ((foo 'bar1)) (setq foo 'bar2)) →
⌜Symbol foo modified in env dyn-bind. New value: bar1
Symbol foo modified in env dyn-local. New value: bar2
Symbol foo modified in env dyn-unbind. New value: bar⌝

(makunbound 'foo) → ⌜Symbol foo modified in env global. New value: none⌝
(setq-local foo 'bar) → ⌜Symbol foo modified in env buffer-local. New value: bar⌝
(makunbound 'foo) → ⌜Symbol foo modified in env buffer-local. New value: none⌝

The varhook property must be a hook. To turn off the varhook, set the property to nil.

The indirection through a hook, rather than putting the list of functions directly in the varhook property, lets you turn the varhook on/off without having to add/remove all your functions on the hook.

After you turn it off, if there are no other properties on the symbol, use
(setf (symbol-plist 'foo) nil)
to get rid of the superfluous property list that just records nil for varhook. If you leave the list there, it causes a minor slowdown (the time required to check whether the property is nil) when setting the symbol. The varhook feature is optimized to immediately skip a symbol if the property list is nil.

Each function on the hook must take two arguments:
0. The symbol S that was set (or bound or unbound), which is passed so you can have one function deal with multiple symbols rather than needing a separate function for each symbol.
1. The environment or event in which S was set/bound/unbound. This is one of the following symbols:
global: S was set in the global env.
buffer-local: S was set in the env of the current buffer.
dyn-local: S was set in the innermost dynamic env in which S is bound.
dyn-bind: S was bound in a new dynamic env (created by dynamic «let»).
dyn-unbind: The innermost dynamic env in which S was bound was destroyed.

For lexical bindings, varhook isn't triggered.

The names ⌜dyn-⌝ are used instead of ⌜let-⌝ for clarity, since ⌜let⌝ is also used for lexical bindings in Lisp.

If your function receives dyn-unbind and tries to read S, it will get the value bound to in an outer env, i.e. in the innermost dynamic env in which S is still bound, or in the buffer-local or global env.

If you're only interested in global settings, just wrap your hook function's body in
(when (eq env 'global) ...)

You get recursion if your function sets the symbol in any env (except lexical). Make sure you have a terminating condition.

The varhook is run not only when the symbol is set, but also when it's made unbound, either globally or buffer-locally. Make sure your function checks for this before trying to read the variable.

Patch applies to trunk.


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

--- src/lisp.h
+++ src/lisp.h
@@ -3391,6 +3391,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 +3446,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);
 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)
+{
+  /* Avoid the call in the usual case of nil property list just to save time. */
+  if (!NILP (sym->plist))
+    run_varhook (sym, buf_local, dir);
+}
+
 /* Defined in cmds.c */
 extern void syms_of_cmds (void);
 extern void keys_of_cmds (void);
@@ -3905,9 +3926,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);
+	}
       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 ();
@@ -3320,6 +3323,7 @@
 	    if (sym->redirect == SYMBOL_PLAINVAL)
 	      {
 		SET_SYMBOL_VAL (sym, specpdl_old_value (specpdl_ptr));
+		try_run_varhook (sym, false, Dyn_Unbind);
 		break;
 	      }
 	    else
@@ -3329,8 +3333,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 +3346,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 +3541,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 +3557,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;
--- src/data.c
+++ src/data.c
@@ -1167,6 +1168,42 @@
   xsignal1 (Qvoid_variable, symbol);
 }
 
+/* For the symbol S that was just set, if the varhook property is set to
+   a hook, run the functions on that hook. To those functions, pass S
+   as the first argument, and as the second argument, pass a symbol
+   indicating the environment in which S was set. */
+
+void
+run_varhook (struct Lisp_Symbol* sym, bool buf_local, Dyn_Bind_Direction dir)
+{
+  Lisp_Object hook_and_args[3];
+  if (dir == Dyn_Skip) /* From backtrace_eval_unrewind */
+    return;
+  hook_and_args[0] = Fplist_get (sym->plist, Qvarhook);
+  if (NILP (hook_and_args[0]))
+    return;
+  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] = Qbuffer_local;
+	else hook_and_args[2] = Qglobal;
+	break;
+      }
+    case Dyn_Global: 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 ();
+    }
+  run_hook_with_args (3, 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 +1224,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 +1264,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);
+	return;
+      }
     case SYMBOL_LOCALIZED:
       {
+	bool buf_local = true;
 	struct Lisp_Buffer_Local_Value *blv = SYMBOL_BLV (sym);
 	if (NILP (where))
 	  {
@@ -1258,6 +1316,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 +1358,7 @@
 				       BUFFERP (where)
 				       ? XBUFFER (where) : current_buffer);
 	  }
+	try_run_varhook (sym, buf_local, dir);
 	break;
       }
     case SYMBOL_FORWARDED:
@@ -1324,6 +1384,9 @@
 	  }
 	else
 	  store_symval_forwarding (/* sym, */ innercontents, newval, buf);
+	try_run_varhook (sym,
+			 (XFWDTYPE (innercontents))==Lisp_Fwd_Buffer_Obj,
+			 dir);
 	break;
       }
     default: emacs_abort ();
@@ -1413,6 +1476,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 +1497,7 @@
 	xsignal1 (Qsetting_constant, symbol);
       else
 	/* Allow setting keywords to their own value.  */
-	return value;
+	return;
     }
   sym = XSYMBOL (symbol);
 
@@ -1431,7 +1505,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 +1520,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);
+	return;
       }
     case SYMBOL_FORWARDED:
       {
@@ -1468,10 +1547,14 @@
 		  if (!PER_BUFFER_VALUE_P (b, idx))
 		    set_per_buffer_value (b, offset, value);
 	      }
-	    return value;
+	    try_run_varhook (sym, false, dir);
+	    return;
 	  }
 	else
-	  return Fset (symbol, value);
+	  {
+	    set_internal_1 (symbol, value, Qnil, false, dir);
+	    return;
+	  }
       }
     default: emacs_abort ();
     }
@@ -3470,6 +3553,13 @@
   DEFSYM (Qad_advice_info, "ad-advice-info");
   DEFSYM (Qad_activate_internal, "ad-activate-internal");
 
+  DEFSYM (Qvarhook, "varhook");
+  DEFSYM (Qglobal, "global");
+  DEFSYM (Qbuffer_local, "buffer-local");
+  DEFSYM (Qdyn_local, "dyn-local");
+  DEFSYM (Qdyn_bind, "dyn-bind");
+  DEFSYM (Qdyn_unbind, "dyn-unbind");
+
   error_tail = pure_cons (Qerror, Qnil);
 
   /* ERROR is used as a signaler for random errors for which nothing else is