feature/improved-locked-narrowing 9dee6df39c: Reworked locked narrowing.

[Gregory Heytings]

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

    Reworked locked narrowing.
    
    * src/editfns.c: (narrowing_locks): New alist to hold the narrowing
    locks and their buffers.
    (narrowing_lock_get_bound, narrowing_lock_peek_tag)
    (narrowing_lock_push, narrowing_lock_pop): New functions to access
    and update 'narrowing_locks'.
    (reset_outermost_narrowings, unwind_reset_outermost_narrowing):
    Functions moved from src/xdisp.c, and rewritten with the above
    functions.
    (Fwiden): Use the above functions. Update docstring.
    (Fnarrow_to_region, Fnarrowing_lock, Fnarrowing_unlock): Use the above
    functions.
    (syms_of_editfns): Remove the 'narrowing-locks' variable.
    
    * src/lisp.h: Make 'reset_outermost_narrowings' externally visible.
    
    * src/xdisp.c (reset_outermost_narrowings)
    unwind_reset_outermost_narrowing): Functions moved to src/editfns.c.
    
    * lisp/subr.el (with-locked-narrowing): Improved macro, with a helper
    function.
---
 lisp/subr.el  |  19 +++---
 src/editfns.c | 212 +++++++++++++++++++++++++++++++++++++++++++++-------------
 src/lisp.h    |   1 +
 src/xdisp.c   |  34 ----------
 4 files changed, 179 insertions(+), 87 deletions(-)

diff --git a/lisp/subr.el b/lisp/subr.el
index 7dd8ff2081..196e7f881b 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -3943,14 +3943,17 @@ within the START and END limits, unless the 
restrictions are
 unlocked by calling `narrowing-unlock' with TAG.  See
 `narrowing-lock' for a more detailed description.  The current
 restrictions, if any, are restored upon return."
-  `(save-restriction
-     (unwind-protect
-         (progn
-           (narrow-to-region ,start ,end)
-           (narrowing-lock ,tag)
-           ,@body)
-       (narrowing-unlock ,tag)
-       (widen))))
+  `(with-locked-narrowing-1 ,start ,end ,tag (lambda () ,@body)))
+
+(defun with-locked-narrowing-1 (start end tag body)
+  "Helper function for `with-locked-narrowing', which see."
+  (save-restriction
+    (unwind-protect
+        (progn
+           (narrow-to-region start end)
+           (narrowing-lock tag)
+           (funcall body))
+       (narrowing-unlock tag))))
 
 (defun find-tag-default-bounds ()
   "Determine the boundaries of the default tag, based on text at point.
diff --git a/src/editfns.c b/src/editfns.c
index c7cc63d8d3..9c81d9c723 100644
--- a/src/editfns.c
+++ b/src/editfns.c
@@ -2653,18 +2653,144 @@ DEFUN ("delete-and-extract-region", 
Fdelete_and_extract_region,
   return del_range_1 (XFIXNUM (start), XFIXNUM (end), 1, 1);
 }
 
+/* Alist of buffers in which locked narrowing is used.  The car of
+   each list element is a buffer, the cdr is a list of triplets (tag
+   begv-marker zv-marker).  The last element of that list always uses
+   the (uninterned) Qoutermost_narrowing tag and records the narrowing
+   bounds that were set by the user and that are visible on display.
+   This alist is used internally by narrow-to-region, widen,
+   narrowing-lock and narrowing-unlock.  */
+static Lisp_Object narrowing_locks;
+
+/* Retrieve one of the BEGV/ZV bounds of a narrowing in BUF from the
+   narrowing_locks alist.  When OUTERMOST is true, the bounds that
+   were set by the user and that are visible on display are returned.
+   Otherwise the innermost locked narrowing bounds are returned.  */
+static ptrdiff_t
+narrowing_lock_get_bound (Lisp_Object buf, bool begv, bool outermost)
+{
+  if (NILP (Fbuffer_live_p (buf)))
+    return 0;
+  Lisp_Object buffer_locks = assq_no_quit (buf, narrowing_locks);
+  if (NILP (buffer_locks))
+    return 0;
+  buffer_locks = Fcar (Fcdr (buffer_locks));
+  Lisp_Object bounds
+    = outermost
+      ? Fcdr (assq_no_quit (Qoutermost_narrowing, buffer_locks))
+      : Fcdr (Fcar (buffer_locks));
+  eassert (! NILP (bounds));
+  Lisp_Object marker = begv ? Fcar (bounds) : Fcar (Fcdr (bounds));
+  eassert (MARKERP (marker));
+  Lisp_Object pos = Fmarker_position (marker);
+  eassert (! NILP (pos));
+  return XFIXNUM (pos);
+}
+
+/* Retrieve the tag of the innermost narrowing in BUF.  */
+static Lisp_Object
+narrowing_lock_peek_tag (Lisp_Object buf)
+{
+  if (NILP (Fbuffer_live_p (buf)))
+    return Qnil;
+  Lisp_Object buffer_locks = assq_no_quit (buf, narrowing_locks);
+  if (NILP (buffer_locks))
+    return Qnil;
+  Lisp_Object tag = Fcar (Fcar (Fcar (Fcdr (buffer_locks))));
+  eassert (! NILP (tag));
+  return tag;
+}
+
+/* Add a LOCK in BUF in the narrowing_locks alist.  */
+static void
+narrowing_lock_push (Lisp_Object buf, Lisp_Object lock)
+{
+  Lisp_Object buffer_locks = assq_no_quit (buf, narrowing_locks);
+  if (NILP (buffer_locks))
+    narrowing_locks = nconc2 (list1 (list2 (buf, list1 (lock))),
+                             narrowing_locks);
+  else
+    Fsetcdr (buffer_locks, list1 (nconc2 (list1 (lock),
+                                         Fcar (Fcdr (buffer_locks)))));
+}
+
+/* Remove the innermost lock in BUF from the narrowing_lock alist.  */
+static void
+narrowing_lock_pop (Lisp_Object buf)
+{
+  Lisp_Object buffer_locks = assq_no_quit (buf, narrowing_locks);
+  eassert (! NILP (buffer_locks));
+  if (EQ (narrowing_lock_peek_tag (buf), Qoutermost_narrowing))
+    narrowing_locks = Fdelq (Fassoc (buf, narrowing_locks, Qnil),
+                            narrowing_locks);
+  else
+    Fsetcdr (buffer_locks, list1 (Fcdr (Fcar (Fcdr (buffer_locks)))));
+}
+
+static void
+unwind_reset_outermost_narrowing (Lisp_Object buf)
+{
+  ptrdiff_t begv, zv;
+  begv = narrowing_lock_get_bound (buf, true, false);
+  zv = narrowing_lock_get_bound (buf, false, false);
+  if (begv && zv)
+    {
+      SET_BUF_BEGV (XBUFFER (buf), begv);
+      SET_BUF_ZV (XBUFFER (buf), zv);
+    }
+}
+
+/* When redisplay is called in a function executed while a locked
+   narrowing is in effect, restore the narrowing bounds that were set
+   by the user, and restore the bounds of the locked narrowing when
+   returning from redisplay.  */
+void
+reset_outermost_narrowings (void)
+{
+  Lisp_Object val, buf;
+  for (val = narrowing_locks; CONSP (val); val = XCDR (val))
+    {
+      buf = Fcar (Fcar (val));
+      eassert (BUFFERP (buf));
+      ptrdiff_t begv = narrowing_lock_get_bound (buf, true, true);
+      ptrdiff_t zv = narrowing_lock_get_bound (buf, false, true);
+      SET_BUF_BEGV (XBUFFER (buf), begv);
+      SET_BUF_ZV (XBUFFER (buf), zv);
+      record_unwind_protect (unwind_reset_outermost_narrowing, buf);
+    }
+}
+
+static void
+unwind_narrow_to_region_locked (Lisp_Object tag)
+{
+  Fnarrowing_unlock (tag);
+  Fwiden ();
+}
+
+/* Narrow current_buffer to BEGV-ZV with a locked narrowing */
+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);
+}
+
 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, unless
 restrictions have been locked with `narrowing-lock', which see, in
-which case the restrictions that were current when `narrowing-lock'
-was called are restored.  */)
+which case the narrowing that was current when `narrowing-lock' was
+called is restored.  */)
   (void)
 {
   Fset (Qoutermost_narrowing, Qnil);
+  Lisp_Object buf = Fcurrent_buffer ();
+  Lisp_Object tag = narrowing_lock_peek_tag (buf);
 
-  if (NILP (Vnarrowing_locks))
+  if (NILP (tag))
     {
       if (BEG != BEGV || Z != ZV)
        current_buffer->clip_changed = 1;
@@ -2674,14 +2800,18 @@ was called are restored.  */)
     }
   else
     {
-      ptrdiff_t begv = XFIXNUM (Fcar (Fcdr (Fcar (Vnarrowing_locks))));
-      ptrdiff_t zv = XFIXNUM (Fcdr (Fcdr (Fcar (Vnarrowing_locks))));
+      ptrdiff_t begv = narrowing_lock_get_bound (buf, true, false);
+      ptrdiff_t zv = narrowing_lock_get_bound (buf, false, false);
       if (begv != BEGV || zv != ZV)
        current_buffer->clip_changed = 1;
       SET_BUF_BEGV (current_buffer, begv);
       SET_BUF_ZV (current_buffer, zv);
-      if (EQ (Fcar (Fcar (Vnarrowing_locks)), Qoutermost_narrowing))
-       Fset (Qnarrowing_locks, Qnil);
+      /* If the only remaining bounds in narrowing_locks for
+        current_buffer are the bounds that were set by the user, no
+        locked narrowing is in effect in current_buffer anymore:
+        remove it from the narrowing_locks alist.  */
+      if (EQ (tag, Qoutermost_narrowing))
+       narrowing_lock_pop (buf);
     }
   /* Changing the buffer bounds invalidates any recorded current column.  */
   invalidate_current_column ();
@@ -2716,20 +2846,25 @@ limit of the locked restriction is used instead of the 
argument.  */)
   if (!(BEG <= s && s <= e && e <= Z))
     args_out_of_range (start, end);
 
-  if (! NILP (Vnarrowing_locks))
+  Lisp_Object buf = Fcurrent_buffer ();
+  if (! NILP (narrowing_lock_peek_tag (buf)))
     {
-      ptrdiff_t begv = XFIXNUM (Fcar (Fcdr (Fcar (Vnarrowing_locks))));
-      ptrdiff_t zv = XFIXNUM (Fcdr (Fcdr (Fcar (Vnarrowing_locks))));
+      ptrdiff_t begv = narrowing_lock_get_bound (buf, true, false);
+      ptrdiff_t zv = narrowing_lock_get_bound (buf, false, false);
+      /* Limit the start and end positions to those of the locked
+        narrowing.  */
       if (s < begv) s = begv;
       if (s > zv) s = zv;
       if (e < begv) e = begv;
       if (e > zv) e = zv;
     }
 
-  Fset (Qoutermost_narrowing,
-       Fcons (Fcons (Qoutermost_narrowing,
-                     Fcons (make_fixnum (BEGV), make_fixnum (ZV))),
-              Qnil));
+  /* Record the accessible range of the buffer when narrow-to-region
+     is called, that is, before applying the narrowing.  It is used
+     only by narrowing-lock.  */
+  Fset (Qoutermost_narrowing, list3 (Qoutermost_narrowing,
+                                    Fpoint_min_marker (),
+                                    Fpoint_max_marker ()));
 
   if (BEGV != s || ZV != e)
     current_buffer->clip_changed = 1;
@@ -2766,11 +2901,18 @@ Locked restrictions are never visible on display, and 
can therefore
 not be used as a stronger variant of normal restrictions.  */)
   (Lisp_Object tag)
 {
-  if (NILP (Vnarrowing_locks))
-    Fset (Qnarrowing_locks, Voutermost_narrowing);
-  Fset (Qnarrowing_locks,
-       Fcons (Fcons (tag, Fcons (make_fixnum (BEGV), make_fixnum (ZV))),
-              Vnarrowing_locks));
+  Lisp_Object buf = Fcurrent_buffer ();
+  Lisp_Object outermost_narrowing
+    = buffer_local_value (Qoutermost_narrowing, buf);
+  /* If narrowing-lock is called without being preceded by
+     narrow-to-region, do nothing.  */
+  if (NILP (outermost_narrowing))
+    return Qnil;
+  if (NILP (narrowing_lock_peek_tag (buf)))
+    narrowing_lock_push (buf, outermost_narrowing);
+  narrowing_lock_push (buf, list3 (tag,
+                                  Fpoint_min_marker (),
+                                  Fpoint_max_marker ()));
   return Qnil;
 }
 
@@ -2786,27 +2928,12 @@ by Emacs around low-level hooks such as 
`fontification-functions' or
 `post-command-hook'.  */)
   (Lisp_Object tag)
 {
-  if (EQ (Fcar (Fcar (Vnarrowing_locks)), tag))
-    Fset (Qnarrowing_locks, Fcdr (Vnarrowing_locks));
+  Lisp_Object buf = Fcurrent_buffer ();
+  if (EQ (narrowing_lock_peek_tag (buf), tag))
+    narrowing_lock_pop (buf);
   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
 save_restriction_save (void)
 {
@@ -4564,6 +4691,8 @@ syms_of_editfns (void)
   DEFSYM (Qwall, "wall");
   DEFSYM (Qpropertize, "propertize");
 
+  staticpro (&narrowing_locks);
+
   DEFVAR_LISP ("inhibit-field-text-motion", Vinhibit_field_text_motion,
               doc: /* Non-nil means text motion commands don't notice fields.  
*/);
   Vinhibit_field_text_motion = Qnil;
@@ -4623,18 +4752,11 @@ This variable is experimental; email 
32252@debbugs.gnu.org if you need
 it to be non-nil.  */);
   binary_as_unsigned = false;
 
-  DEFSYM (Qnarrowing_locks, "narrowing-locks");
-  DEFVAR_LISP ("narrowing-locks", Vnarrowing_locks,
-              doc: /* List of narrowing locks in the current buffer.  Internal 
use only.  */);
-  Vnarrowing_locks = Qnil;
-  Fmake_variable_buffer_local (Qnarrowing_locks);
-  Funintern (Qnarrowing_locks, Qnil);
-
-  DEFSYM (Qoutermost_narrowing, "outermost-narrowing");
   DEFVAR_LISP ("outermost-narrowing", Voutermost_narrowing,
               doc: /* Outermost narrowing bounds, if any.  Internal use only.  
*/);
   Voutermost_narrowing = Qnil;
   Fmake_variable_buffer_local (Qoutermost_narrowing);
+  DEFSYM (Qoutermost_narrowing, "outermost-narrowing");
   Funintern (Qoutermost_narrowing, Qnil);
 
   defsubr (&Spropertize);
diff --git a/src/lisp.h b/src/lisp.h
index 8a5b8dad83..373aee2287 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -4683,6 +4683,7 @@ 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 void narrow_to_region_locked (Lisp_Object, Lisp_Object, Lisp_Object);
+extern void reset_outermost_narrowings (void);
 extern void init_editfns (void);
 extern void syms_of_editfns (void);
 
diff --git a/src/xdisp.c b/src/xdisp.c
index fa5ce84b1c..658ce57b7e 100644
--- a/src/xdisp.c
+++ b/src/xdisp.c
@@ -16266,40 +16266,6 @@ do { if (! polling_stopped_here) stop_polling ();      
\
 do { if (polling_stopped_here) start_polling ();       \
        polling_stopped_here = false; } while (false)
 
-static void
-unwind_reset_outermost_narrowing (Lisp_Object buf)
-{
-  Lisp_Object innermost_narrowing =
-    Fcar (buffer_local_value (Qnarrowing_locks, buf));
-  if (! NILP (innermost_narrowing))
-    {
-      SET_BUF_BEGV (XBUFFER (buf),
-                   XFIXNUM (Fcar (Fcdr (innermost_narrowing))));
-      SET_BUF_ZV (XBUFFER (buf),
-                 XFIXNUM (Fcdr (Fcdr (innermost_narrowing))));
-    }
-}
-
-static void
-reset_outermost_narrowings (void)
-{
-  Lisp_Object tail, buf, outermost_narrowing;
-  FOR_EACH_LIVE_BUFFER (tail, buf)
-    {
-      outermost_narrowing =
-       Fassq (Qoutermost_narrowing,
-              buffer_local_value (Qnarrowing_locks, buf));
-      if (!NILP (outermost_narrowing))
-       {
-         SET_BUF_BEGV (XBUFFER (buf),
-                       XFIXNUM (Fcar (Fcdr (outermost_narrowing))));
-         SET_BUF_ZV (XBUFFER (buf),
-                     XFIXNUM (Fcdr (Fcdr (outermost_narrowing))));
-         record_unwind_protect (unwind_reset_outermost_narrowing, buf);
-       }
-    }
-}
-
 /* Perhaps in the future avoid recentering windows if it
    is not necessary; currently that causes some problems.  */