From 67c5f0635a98e697e57086784c0fed4651f54ee2 Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Tue, 13 May 2025 12:21:21 +0100 Subject: [PATCH] New top-level buffer-local value functions * src/eval.c (local_toplevel_binding) (Fbuffer_local_toplevel_value, Fset_buffer_local_toplevel_value) (syms_of_eval): New functions. * doc/lispref/variables.texi (Default Value): * lisp/subr.el (setq-local): * etc/NEWS: Document them. * test/lisp/emacs-lisp/lisp-tests.el (core-elisp-tests-4-toplevel-values): New test. * lisp/progmodes/xref.el (xref--show-xref-buffer) (xref-show-definitions-buffer-at-bottom): * lisp/vc/vc-dispatcher.el (vc-setup-buffer): Use set-buffer-local-toplevel-value. (cherry picked from commit 45627ca7ccd0e84452d497997a7f75535ed83864) --- doc/lispref/variables.texi | 32 ++++++++++++++ lisp/progmodes/xref.el | 8 +++- lisp/subr.el | 3 ++ lisp/vc/vc-dispatcher.el | 14 +----- src/eval.c | 70 ++++++++++++++++++++++++++++++ src/lisp.h | 3 +- test/lisp/emacs-lisp/lisp-tests.el | 31 +++++++++++++ 7 files changed, 145 insertions(+), 16 deletions(-) diff --git a/doc/lispref/variables.texi b/doc/lispref/variables.texi index c007d857c37..005db3401b1 100644 --- a/doc/lispref/variables.texi +++ b/doc/lispref/variables.texi @@ -1941,6 +1941,38 @@ global value of @var{symbol} regardless of whether your code runs in the context of @var{symbol}'s let-binding. @end defun +@cindex top-level buffer-local value + In addition, a variable's buffer-local value may be shadowed by a +let-binding. There are two further functions to get and set the +top-level buffer-local value of a variable. + +@defun buffer-local-toplevel-value symbol &optional buffer +This function returns the local value for @var{symbol} in @var{buffer}, +defaulting to the current buffer, outside of any let-binding. If +@var{symbol} is not local in @var{buffer}, this function signals an +error. +@end defun + +@defun set-buffer-local-toplevel-value symbol value &optional buffer +This function sets the local value of @var{symbol} to @var{value} in +@var{buffer}, defaulting to the current buffer, outside of any +let-binding. + +@var{symbol} is made local in @var{buffer} if it was not already. For +global variables, this means @var{symbol} will have a separate value in +@var{buffer}; for variables that are automatically buffer-local, this +function causes a local value for them to exist in @var{buffer}. If +@var{symbol} is permanently buffer-local, @var{value} will now persist +as the buffer-local value for the variable across changes of major mode. + +This is useful when you want to make a change to a buffer-local value +that will persist after the command now being executed completes, but +where your code may be executed with that variable let-bound. In this +case the usual tool for setting buffer-local values, @code{setq-local}, +will only change the value of the let-binding, and not the underlying +buffer-local value. This function sets the latter. +@end defun + @node File Local Variables @section File Local Variables diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el index 0ba209bc72d..b5b2e368e43 100644 --- a/lisp/progmodes/xref.el +++ b/lisp/progmodes/xref.el @@ -1372,7 +1372,9 @@ this variable to an alist with the following key-value pairs: (xref-alist (xref--analyze xrefs)) (dd default-directory)) (with-current-buffer (get-buffer-create xref-buffer-name) - (xref--ensure-default-directory dd (current-buffer)) + (if (fboundp 'set-buffer-local-toplevel-value) + (set-buffer-local-toplevel-value 'default-directory dd) + (xref--ensure-default-directory dd (current-buffer))) (xref--xref-buffer-mode) (xref--show-common-initialize xref-alist fetcher (append xref-fetcher-alist alist)) (setq mode-line-process (list xref-mode-line-matches)) @@ -1495,7 +1497,9 @@ local keymap that binds `RET' to `xref-quit-and-goto-xref'." (setq xref-alist (xref--analyze xrefs)) (with-current-buffer (get-buffer-create xref-buffer-name) - (xref--ensure-default-directory dd (current-buffer)) + (if (fboundp 'set-buffer-local-toplevel-value) + (set-buffer-local-toplevel-value 'default-directory dd) + (xref--ensure-default-directory dd (current-buffer))) (xref--transient-buffer-mode) (xref--show-common-initialize xref-alist fetcher (append xref-fetcher-alist alist)) (pop-to-buffer (current-buffer) diff --git a/lisp/subr.el b/lisp/subr.el index bbd0b32a31c..d6f05ab4d6c 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -174,6 +174,9 @@ of VARIABLEs set by earlier pairs. The return value of the `setq-local' form is the VALUE of the last pair. +In some corner cases you may need to resort to +`set-buffer-local-toplevel-value' instead, which see. + \(fn [VARIABLE VALUE]...)" (declare (debug setq)) (unless (evenp (length pairs)) diff --git a/lisp/vc/vc-dispatcher.el b/lisp/vc/vc-dispatcher.el index 8f72deb355a..5bcbc648600 100644 --- a/lisp/vc/vc-dispatcher.el +++ b/lisp/vc/vc-dispatcher.el @@ -199,19 +199,7 @@ Another is that undo information is not kept." (setq-local vc-parent-buffer-name (concat " from " (buffer-name camefrom)))) - ;; We want to set the buffer-local value of `default-directory' to - ;; olddir. This `setq' alone ought to be sufficient. But if there - ;; is a let-binding of `default-directory' in effect, such as the - ;; one established by `vc-print-root-log', then all we are able to - ;; do is change the let-binding, and not affect the underlying - ;; buffer-local cell. Work around this using `run-with-timer'. - ;; See bug#53626 and bug#77306. - (setq default-directory olddir) - (run-with-timer 0 nil (lambda () - (when (buffer-live-p buf) - (with-current-buffer buf - (setq default-directory olddir))))) - + (set-buffer-local-toplevel-value 'default-directory olddir) (let ((buffer-undo-list t) (inhibit-read-only t)) (erase-buffer)))) diff --git a/src/eval.c b/src/eval.c index 348157c87be..ede79b9f77d 100644 --- a/src/eval.c +++ b/src/eval.c @@ -759,6 +759,27 @@ default_toplevel_binding (Lisp_Object symbol) return binding; } +static union specbinding * +local_toplevel_binding (Lisp_Object symbol, Lisp_Object buf) +{ + union specbinding *binding = NULL; + union specbinding *pdl = specpdl_ptr; + while (pdl > specpdl) + { + switch ((--pdl)->kind) + { + case SPECPDL_LET_LOCAL: + if (BASE_EQ (specpdl_where (pdl), buf) + && EQ (specpdl_symbol (pdl), symbol)) + binding = pdl; + break; + + default: break; + } + } + return binding; +} + /* Look for a lexical-binding of SYMBOL somewhere up the stack. This will only find bindings created with interpreted code, since once compiled names of lexical variables are basically gone anyway. */ @@ -813,6 +834,53 @@ DEFUN ("set-default-toplevel-value", Fset_default_toplevel_value, return Qnil; } +DEFUN ("buffer-local-toplevel-value", + Fbuffer_local_toplevel_value, + Sbuffer_local_toplevel_value, 1, 2, 0, + doc: /* Return SYMBOL's toplevel local value in BUFFER. +"Toplevel" means outside of any let binding. +BUFFER defaults to the current buffer. +If SYMBOL has no local value in BUFFER, signals an error. */) + (Lisp_Object symbol, Lisp_Object buffer) +{ + if (NILP (buffer)) + buffer = Fcurrent_buffer (); + if (NILP (Flocal_variable_p (symbol, buffer))) + xsignal1 (Qvoid_variable, symbol); + union specbinding *binding = local_toplevel_binding (symbol, buffer); + return binding + ? specpdl_old_value (binding) + : Fbuffer_local_value (symbol, buffer); +} + +DEFUN ("set-buffer-local-toplevel-value", + Fset_buffer_local_toplevel_value, + Sset_buffer_local_toplevel_value, 2, 3, 0, + doc: /* Set SYMBOL's toplevel local value to VALUE in BUFFER. +"Toplevel" means outside of any let binding. +BUFFER defaults to the current buffer. +Makes SYMBOL buffer-local in BUFFER if it was not already. */) + (Lisp_Object symbol, Lisp_Object value, Lisp_Object buffer) +{ + Lisp_Object buf = !NILP (buffer) ? buffer : Fcurrent_buffer (); + union specbinding *binding = local_toplevel_binding (symbol, buf); + + if (binding) + set_specpdl_old_value (binding, value); + else if (NILP (buffer)) + Fset (Fmake_local_variable (symbol), value); + else + { + specpdl_ref count = SPECPDL_INDEX (); + record_unwind_current_buffer (); + Fset_buffer (buffer); + Fset (Fmake_local_variable (symbol), value); + unbind_to (count, Qnil); + } + + return Qnil; +} + DEFUN ("internal--define-uninitialized-variable", Finternal__define_uninitialized_variable, Sinternal__define_uninitialized_variable, 1, 2, 0, @@ -4503,6 +4571,8 @@ alist of active lexical bindings. */); defsubr (&Smake_interpreted_closure); defsubr (&Sdefault_toplevel_value); defsubr (&Sset_default_toplevel_value); + defsubr (&Sbuffer_local_toplevel_value); + defsubr (&Sset_buffer_local_toplevel_value); defsubr (&Sdefvar); defsubr (&Sdefvar_1); defsubr (&Sdefvaralias); diff --git a/src/lisp.h b/src/lisp.h index 156455dd35b..ad4f2506126 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -3496,7 +3496,7 @@ extern void defvar_kboard (struct Lisp_Kboard_Objfwd const *, char const *); These are used in the syms_of_FILENAME functions. An ordinary (not in buffer_defaults, per-buffer, or per-keyboard) - lisp variable is actually a field in `struct emacs_globals'. The + Lisp variable is actually a field in `struct emacs_globals'. The field's name begins with "f_", which is a convention enforced by these macros. Each such global has a corresponding #define in globals.h; the plain name should be used in the code. @@ -3547,6 +3547,7 @@ extern void defvar_kboard (struct Lisp_Kboard_Objfwd const *, char const *); - The specpdl stack keeps track of backtraces, unwind-protects and dynamic let-bindings. It is allocated from the 'specpdl' array, a manually managed stack. + ("pdl" stands for "push-down list" which just means "stack".) - The handler stack keeps track of active catch tags and condition-case handlers. It is allocated in a manually managed stack implemented by a doubly-linked list allocated via xmalloc and never freed. */ diff --git a/test/lisp/emacs-lisp/lisp-tests.el b/test/lisp/emacs-lisp/lisp-tests.el index 9bd9fc3d4f3..1ef6bc864a7 100644 --- a/test/lisp/emacs-lisp/lisp-tests.el +++ b/test/lisp/emacs-lisp/lisp-tests.el @@ -238,6 +238,37 @@ (ert-deftest core-elisp-tests-3-backquote () (should (eq 3 (eval ``,,'(+ 1 2) t)))) +(defvar-local c-e-l 'foo) +(ert-deftest core-elisp-tests-4-toplevel-values () + (setq-default c-e-l 'foo) + (let ((c-e-l 'bar)) + (let ((c-e-l 'baz)) + (setq-default c-e-l 'bar) + (should (eq c-e-l 'bar)) + (should (eq (default-toplevel-value 'c-e-l) 'foo)) + (set-default-toplevel-value 'c-e-l 'baz) + (should (eq c-e-l 'bar)) + (should (eq (default-toplevel-value 'c-e-l) 'baz)))) + (let ((c-e-u 'foo)) + (should (condition-case _ + (default-toplevel-value 'c-e-u) + (void-variable t)))) + (with-temp-buffer + (setq-local c-e-l 'bar) + (should (eq (buffer-local-toplevel-value 'c-e-l) 'bar)) + (let ((c-e-l 'baz)) + (let ((c-e-l 'quux)) + (setq-local c-e-l 'baz) + (should (eq c-e-l 'baz)) + (should (eq (buffer-local-toplevel-value 'c-e-l) 'bar)) + (set-buffer-local-toplevel-value 'c-e-l 'foo) + (should (eq c-e-l 'baz)) + (should (eq (buffer-local-toplevel-value 'c-e-l) 'foo))))) + (with-temp-buffer + (should (condition-case _ + (buffer-local-toplevel-value 'c-e-l) + (void-variable t))))) + ;; Test up-list and backward-up-list. (defun lisp-run-up-list-test (fn data start instructions) (cl-labels ((posof (thing) -- 2.39.5