From 2727af3fd448e39f79e130c42286e85a51bf7a40 Mon Sep 17 00:00:00 2001 From: Gregory Heytings Date: Sat, 20 Aug 2022 16:06:15 +0000 Subject: [PATCH] Improved locked narrowing. * src/editfns.c (Fnarrowing_lock, Fnarrowing_unlock, narrow_to_region_locked, unwind_narrow_to_region_locked): New functions. (Fnarrow_to_region, Fwiden): Adapt, and make it possible to use these functions within the bounds of the locked narrowing. (syms_of_editfns): Change the name of the variable, make it buffer-local, and add the two Snarrowing_lock and Snarrowing_unlock subroutines. * src/lisp.h: Prototype of 'narrow_to_region_locked'. * src/xdisp.c (handle_fontified_prop): * src/keyboard.c (safe_run_hooks_maybe_narrowed): Use 'narrow_to_region_locked'. * lisp/subr.el (with-locked-narrowing): New macro. --- lisp/subr.el | 14 +++++ src/editfns.c | 168 ++++++++++++++++++++++++++++--------------------- src/keyboard.c | 6 +- src/lisp.h | 2 +- src/xdisp.c | 4 +- 5 files changed, 115 insertions(+), 79 deletions(-) diff --git a/lisp/subr.el b/lisp/subr.el index cd6a9be099c..35c8e086e3a 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -3914,6 +3914,20 @@ See also `locate-user-emacs-file'.") "Return non-nil if the current buffer is narrowed." (/= (- (point-max) (point-min)) (buffer-size))) +(defmacro with-locked-narrowing (start end tag &rest body) + "Execute BODY with restrictions set to START and END and locked with TAG. + +Inside BODY, `narrow-to-region' and `widen' can be used only +within the START and END limits, unless the restrictions are +unlocked by calling `narrowing-unlock' with TAG." + `(unwind-protect + (progn + (narrow-to-region ,start ,end) + (narrowing-lock ,tag) + ,@body) + (narrowing-unlock ,tag) + (widen))) + (defun find-tag-default-bounds () "Determine the boundaries of the default tag, based on text at point. Return a cons cell with the beginning and end of the found tag. diff --git a/src/editfns.c b/src/editfns.c index 16262381999..6987c44f986 100644 --- a/src/editfns.c +++ b/src/editfns.c @@ -2685,44 +2685,50 @@ DEFUN ("delete-and-extract-region", Fdelete_and_extract_region, DEFUN ("widen", Fwiden, Swiden, 0, 0, "", doc: /* Remove restrictions (narrowing) from current buffer. -This allows the buffer's full text to be seen and edited. -Note that, when the current buffer contains one or more lines whose -length is above `long-line-threshold', Emacs may decide to leave, for -performance reasons, the accessible portion of the buffer unchanged -after this function is called from low-level hooks, such as -`jit-lock-functions' or `post-command-hook'. */) +This allows the buffer's full text to be seen and edited, unless +the restrictions have been locked with `narrowing-lock', which see, +in which case the the restrictions that were current when +`narrowing-lock' was called are restored. */) (void) { - if (! NILP (Vrestrictions_locked)) - return Qnil; - if (BEG != BEGV || Z != ZV) - current_buffer->clip_changed = 1; - BEGV = BEG; - BEGV_BYTE = BEG_BYTE; - SET_BUF_ZV_BOTH (current_buffer, Z, Z_BYTE); + if (NILP (Vnarrowing_locks)) + { + if (BEG != BEGV || Z != ZV) + current_buffer->clip_changed = 1; + BEGV = BEG; + BEGV_BYTE = BEG_BYTE; + SET_BUF_ZV_BOTH (current_buffer, Z, Z_BYTE); + } + else + { + ptrdiff_t begv = XFIXNUM (Fcar (Fcdr (Fcar (Vnarrowing_locks)))); + ptrdiff_t zv = XFIXNUM (Fcdr (Fcdr (Fcar (Vnarrowing_locks)))); + if (begv != BEGV || zv != ZV) + current_buffer->clip_changed = 1; + SET_BUF_BEGV (current_buffer, begv); + SET_BUF_ZV (current_buffer, zv); + } /* Changing the buffer bounds invalidates any recorded current column. */ invalidate_current_column (); return Qnil; } -static void -unwind_locked_begv (Lisp_Object point_min) -{ - SET_BUF_BEGV (current_buffer, XFIXNUM (point_min)); -} +DEFUN ("narrow-to-region", Fnarrow_to_region, Snarrow_to_region, 2, 2, "r", + doc: /* Restrict editing in this buffer to the current region. +The rest of the text becomes temporarily invisible and untouchable +but is not deleted; if you save the buffer in a file, the invisible +text is included in the file. \\[widen] makes all visible again. +See also `save-restriction'. -static void -unwind_locked_zv (Lisp_Object point_max) -{ - SET_BUF_ZV (current_buffer, XFIXNUM (point_max)); -} +When calling from Lisp, pass two arguments START and END: +positions (integers or markers) bounding the text that should +remain visible. -/* Internal function for Fnarrow_to_region, meant to be used with a - third argument 'true', in which case it should be followed by "specbind - (Qrestrictions_locked, Qt)". */ -Lisp_Object -narrow_to_region_internal (Lisp_Object start, Lisp_Object end, bool lock) +When restrictions have been locked with `narrowing-lock', which see, +`narrow-to-region' can be used only within the limits of the +restrictions that were current when `narrowing-lock' was called. */) + (Lisp_Object start, Lisp_Object end) { EMACS_INT s = fix_position (start), e = fix_position (end); @@ -2731,35 +2737,24 @@ narrow_to_region_internal (Lisp_Object start, Lisp_Object end, bool lock) EMACS_INT tem = s; s = e; e = tem; } - if (lock) + if (NILP (Vnarrowing_locks)) { - if (!(BEGV <= s && s <= e && e <= ZV)) + if (!(BEG <= s && s <= e && e <= Z)) args_out_of_range (start, end); - - if (BEGV != s || ZV != e) - current_buffer->clip_changed = 1; - - record_unwind_protect (restore_point_unwind, Fpoint_marker ()); - record_unwind_protect (unwind_locked_begv, Fpoint_min ()); - record_unwind_protect (unwind_locked_zv, Fpoint_max ()); - - SET_BUF_BEGV (current_buffer, s); - SET_BUF_ZV (current_buffer, e); } else { - if (! NILP (Vrestrictions_locked)) - return Qnil; - - if (!(BEG <= s && s <= e && e <= Z)) + ptrdiff_t begv = XFIXNUM (Fcar (Fcdr (Fcar (Vnarrowing_locks)))); + ptrdiff_t zv = XFIXNUM (Fcdr (Fcdr (Fcar (Vnarrowing_locks)))); + if (!(begv <= s && s <= e && e <= zv)) args_out_of_range (start, end); + } - if (BEGV != s || ZV != e) - current_buffer->clip_changed = 1; + if (BEGV != s || ZV != e) + current_buffer->clip_changed = 1; - SET_BUF_BEGV (current_buffer, s); - SET_BUF_ZV (current_buffer, e); - } + SET_BUF_BEGV (current_buffer, s); + SET_BUF_ZV (current_buffer, e); if (PT < s) SET_PT (s); @@ -2770,25 +2765,51 @@ narrow_to_region_internal (Lisp_Object start, Lisp_Object end, bool lock) return Qnil; } -DEFUN ("narrow-to-region", Fnarrow_to_region, Snarrow_to_region, 2, 2, "r", - doc: /* Restrict editing in this buffer to the current region. -The rest of the text becomes temporarily invisible and untouchable -but is not deleted; if you save the buffer in a file, the invisible -text is included in the file. \\[widen] makes all visible again. -See also `save-restriction'. +DEFUN ("narrowing-lock", Fnarrowing_lock, Snarrowing_lock, 1, 1, "", + doc: /* Lock the current narrowing with TAG. -When calling from Lisp, pass two arguments START and END: -positions (integers or markers) bounding the text that should -remain visible. +When restrictions are locked, `narrow-to-region' and `widen' can be +used only within the limits of the restrictions that were current when +`narrowing-lock' was called. */) + (Lisp_Object tag) +{ + Fset (Qnarrowing_locks, + Fcons (Fcons (tag, Fcons (make_fixnum (BEGV), make_fixnum (ZV))), + Vnarrowing_locks)); + return Qnil; +} -Note that, when the current buffer contains one or more lines whose -length is above `long-line-threshold', Emacs may decide to leave, for -performance reasons, the accessible portion of the buffer unchanged -after this function is called from low-level hooks, such as -`jit-lock-functions' or `post-command-hook'. */) - (Lisp_Object start, Lisp_Object end) +DEFUN ("narrowing-unlock", Fnarrowing_unlock, Snarrowing_unlock, 1, 1, "", + doc: /* Unlock a narrowing locked with (narrowing-lock TAG). + +Unlocking restrictions locked with `narrowing-lock' should be used +sparingly, after carefully considering the reasons why restrictions +were locked. Restrictions are typically locked around portions of +code that would become too slow, and make Emacs unresponsive, if they +were executed in a large buffer. For example, restrictions are locked +by Emacs around low-level hooks such as `fontification-functions' or +`post-command-hook'. */) + (Lisp_Object tag) { - return narrow_to_region_internal (start, end, false); + if (EQ (Fcar (Fcar (Vnarrowing_locks)), tag)) + Fset (Qnarrowing_locks, Fcdr (Vnarrowing_locks)); + return Qnil; +} + +static void +unwind_narrow_to_region_locked (Lisp_Object tag) +{ + Fnarrowing_unlock (tag); + Fwiden (); +} + +void +narrow_to_region_locked (Lisp_Object begv, Lisp_Object zv, Lisp_Object tag) +{ + Fnarrow_to_region (begv, zv); + Fnarrowing_lock (tag); + record_unwind_protect (restore_point_unwind, Fpoint_marker ()); + record_unwind_protect (unwind_narrow_to_region_locked, tag); } Lisp_Object @@ -4601,14 +4622,13 @@ This variable is experimental; email 32252@debbugs.gnu.org if you need it to be non-nil. */); binary_as_unsigned = false; - DEFSYM (Qrestrictions_locked, "restrictions-locked"); - DEFVAR_LISP ("restrictions-locked", Vrestrictions_locked, - doc: /* If non-nil, restrictions are currently locked. - -This happens when `narrow-to-region', which see, is called from Lisp -with an optional argument LOCK non-nil. */); - Vrestrictions_locked = Qnil; - Funintern (Qrestrictions_locked, Qnil); + DEFSYM (Qnarrowing_locks, "narrowing-locks"); + DEFVAR_LISP ("narrowing-locks", Vnarrowing_locks, + doc: /* Internal use only. +List of narrowing locks in the current buffer. */); + Vnarrowing_locks = Qnil; + Fmake_variable_buffer_local (Qnarrowing_locks); + Funintern (Qnarrowing_locks, Qnil); defsubr (&Spropertize); defsubr (&Schar_equal); @@ -4701,6 +4721,8 @@ with an optional argument LOCK non-nil. */); defsubr (&Sdelete_and_extract_region); defsubr (&Swiden); defsubr (&Snarrow_to_region); + defsubr (&Snarrowing_lock); + defsubr (&Snarrowing_unlock); defsubr (&Ssave_restriction); defsubr (&Stranspose_regions); } diff --git a/src/keyboard.c b/src/keyboard.c index 1d7125a0a3e..4948ea40e40 100644 --- a/src/keyboard.c +++ b/src/keyboard.c @@ -1932,9 +1932,9 @@ safe_run_hooks_maybe_narrowed (Lisp_Object hook, struct window *w) specbind (Qinhibit_quit, Qt); if (current_buffer->long_line_optimizations_p) - narrow_to_region_internal (make_fixnum (get_narrowed_begv (w, PT)), - make_fixnum (get_narrowed_zv (w, PT)), - true); + narrow_to_region_locked (make_fixnum (get_narrowed_begv (w, PT)), + make_fixnum (get_narrowed_zv (w, PT)), + hook); run_hook_with_args (2, ((Lisp_Object []) {hook, hook}), safe_run_hook_funcall); unbind_to (count, Qnil); diff --git a/src/lisp.h b/src/lisp.h index 2f73ba4c617..896406b6a0d 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -4680,7 +4680,7 @@ extern void save_restriction_restore (Lisp_Object); extern Lisp_Object make_buffer_string (ptrdiff_t, ptrdiff_t, bool); extern Lisp_Object make_buffer_string_both (ptrdiff_t, ptrdiff_t, ptrdiff_t, ptrdiff_t, bool); -extern Lisp_Object narrow_to_region_internal (Lisp_Object, Lisp_Object, bool); +extern void narrow_to_region_locked (Lisp_Object, Lisp_Object, Lisp_Object); extern void init_editfns (void); extern void syms_of_editfns (void); diff --git a/src/xdisp.c b/src/xdisp.c index 03c43be5bc0..8f63b029c1f 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -4402,8 +4402,8 @@ handle_fontified_prop (struct it *it) begv = get_narrowed_begv (it->w, charpos); zv = get_narrowed_zv (it->w, charpos); } - narrow_to_region_internal (make_fixnum (begv), make_fixnum (zv), true); - specbind (Qrestrictions_locked, Qt); + narrow_to_region_locked (make_fixnum (begv), make_fixnum (zv), + Qfontification_functions); } /* Don't allow Lisp that runs from 'fontification-functions' -- 2.39.5