feature/improved-locked-narrowing 2727af3fd4: Improved locked narrowing.

[Gregory Heytings]

branch: feature/improved-locked-narrowing
commit 2727af3fd448e39f79e130c42286e85a51bf7a40
Author: Gregory Heytings <gregory@heytings.org>
Commit: Gregory Heytings <gregory@heytings.org>

    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 cd6a9be099..35c8e086e3 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 1626238199..6987c44f98 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 1d7125a0a3..4948ea40e4 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 2f73ba4c61..896406b6a0 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 03c43be5bc..8f63b029c1 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'