Change the format for adjust-marker entries in the undo-list

The format is now:
(apply 0 BEG END undo--adjust-weak-markers ({TPOS {(ID . OFFSET)}*}*))

This no longer exposes the hash table and creates fewer entries.  The
marker for an id can be obtained with the new function
undo--lookup-marker.

The TPOS argument is new; it's needed to test the expected marker
position.  Previously this was implicitly given by the preceding
(TEXT . POSITION) deletion entry.  As undo--adjust-weak-markers is now a
proper function this was necessary.

* lisp/simple.el (undo--adjust-weak-markers): New function.
(primitive-undo): Move the adjust-weak-marker code to
undo--adjust-weak-markers.
* src/undo.c (Qundo__adjust_weak_markers): Renamed
from Qundo__adjust_weak_marker.
(Fundo__lookup_marker): New defun.
(scrub_id_object_pairs): New helper.
(scrub_undo_list, record_marker_adjustments): Adjust for the new format.
(syms_of_undo): Register Fundo__lookup_marker.
* test/src/editfns-tests.el (delete-region-undo-markers-1)
(delete-region-undo-markers-2): Adjust form the new format.
* test/lisp/erc/erc-tests.el (erc-update-undo-list): Adjust for the new
format.

lisp/simple.el

@@ -3741,18 +3741,6 @@ Return what remains of the list."
                  (and (eq (marker-buffer m) (current-buffer))
                       (= apos m)
                       (push marker-adj valid-marker-adjustments))))
-             ;; The same for weakly held markers
-             (while (pcase-exhaustive (car list)
-                      (`(apply undo--adjust-weak-marker ,ht ,id ,distance)
-                       (pop list)
-                       (let ((m (gethash id ht)))
-                         (when (and m
-                                    (eq (marker-buffer m) (current-buffer))
-                                    (= apos m))
-                           (push (cons m distance)
-                                 valid-marker-adjustments)))
-                       t)
-                      (`,_ nil)))
              ;; Insert string and adjust point
              (if (< pos 0)
                  (progn
@@ -3791,6 +3779,33 @@ Return what remains of the list."
               (cons (list 'apply 'cdr nil) buffer-undo-list))))
   list)
 
+;; ARGS has the format: ({TPOS {(ID . OFFSET)}* }* )
+;;
+;; ID is the id for a marker.  The marker can be obtained with
+;; undo--lookup-marker.
+;;
+;; OFFSET should be added to the marker's current position.
+;;
+;; TPOS is an integer that encodes the expected position and the
+;; insertion type of the marker.  The expected position is (abs TPOS)
+;; and the insertion type is t if TPOS is negative.  Markers that don't
+;; match the expected position and insertion type are ignored.
+(defun undo--adjust-weak-markers (&rest args)
+  (while args
+    (let* ((tpos (pop args))
+           (insertion-type (< tpos 0))
+           (pos (abs tpos)))
+      (while (consp (car args))
+        (let* ((pair (pop args))
+               (id (car pair))
+               (offset (cdr pair))
+               (m (undo--lookup-marker id)))
+          (when (and m
+                     (eq (marker-buffer m) (current-buffer))
+                     (eq (marker-insertion-type m) insertion-type)
+                     (= pos m))
+            (set-marker m (+ pos offset))))))))
+
 ;; Deep copy of a list
 (defun undo-copy-list (list)
   "Make a copy of undo list LIST."

src/undo.c

@@ -149,6 +149,33 @@ struct weak_marker_table
 
 static struct weak_marker_table weak_marker_table;
 
+static Lisp_Object
+scrub_id_object_pairs (Lisp_Object id_to_marker, Lisp_Object list)
+{
+  Lisp_Object tail = list, *prev = &list;
+  while (CONSP (tail))
+    {
+      eassert (XFIXNUM (XCAR (tail)));
+      Lisp_Object *prev2 = prev;
+      prev = xcdr_addr (tail);
+      tail = XCDR (tail);
+      while (CONSP (tail) && CONSP (XCAR (tail)))
+	{
+	  Lisp_Object id = XCAR (XCAR (tail));
+	  if (NILP (Fgethash (id, id_to_marker, Qnil)))
+	    *prev = XCDR (tail);
+	  else
+	    prev = xcdr_addr (tail);
+	  tail = XCDR (tail);
+	}
+      if (NILP (XCDR (*prev2)) || FIXNUMP (XCAR (XCDR (*prev2))))
+	{
+	  prev = prev2;
+	  *prev = tail;
+	}
+    }
+  return list;
+}
 /* Remove (apply undo--adjust-weak-marker HASHTABLE KEY D) entries
    where KEY is no longer in HASHTABLE.  */
 
@@ -159,11 +186,21 @@ scrub_undo_list (Lisp_Object list)
 
   for (tail = list; CONSP (tail); tail = XCDR (tail))
     {
+      bool drop = false;
       Lisp_Object entry = XCAR (tail);
       if (CONSP (entry) && EQ (Qapply, XCAR (entry))
-	  && EQ (Qundo__adjust_weak_marker, XCAR (XCDR (entry)))
+	  && FIXNUMP (Fnth (make_fixnum (1), entry))
-	  && NILP (Fgethash (Fnth (make_fixnum (3), entry),
+	  && EQ (Fnth (make_fixnum (4), entry),
-			     Fnth (make_fixnum (2), entry), Qnil)))
+		 Qundo__adjust_weak_markers))
+	{
+	  Lisp_Object htab = weak_marker_table.id_to_marker;
+	  Lisp_Object head = Fnthcdr (make_fixnum (4), entry);
+	  Lisp_Object pairs =
+	    scrub_id_object_pairs (htab, XCDR (head));
+	  XSETCDR (head, pairs);
+	  drop = NILP (pairs);
+	}
+      if (drop)
 	*prev = XCDR (tail);
       else
 	prev = xcdr_addr (tail);
@@ -217,6 +254,15 @@ alloc_weak_marker_id (struct weak_marker_table *t, Lisp_Object marker)
   return id;
 }
 
+DEFUN ("undo--lookup-marker", Fundo__lookup_marker, Sundo__lookup_marker,
+       1, 1, 0,
+       doc: /* Find the marker for id ID.
+If the marker no longer exists, return nil.  */)
+  (Lisp_Object id)
+{
+  return Fgethash (id, weak_marker_table.id_to_marker, Qnil);
+}
+
 #endif
 
 /* Record the fact that markers in the region of FROM, TO are about to
@@ -230,6 +276,49 @@ record_marker_adjustments (ptrdiff_t from, ptrdiff_t to)
 {
   prepare_record ();
 
+#ifdef HAVE_MPS
+  Lisp_Object left = Qnil;
+  Lisp_Object right = Qnil;
+
+  DO_MARKERS (current_buffer, m)
+    {
+      ptrdiff_t charpos = m->charpos;
+      eassert (charpos <= Z);
+      if (!(from <= charpos && charpos <= to))
+	continue;
+      ptrdiff_t delta = charpos - (m->insertion_type ? to : from);
+      if (delta == 0)
+	continue;
+      Lisp_Object marker = make_lisp_ptr (m, Lisp_Vectorlike);
+      Lisp_Object id
+	= alloc_weak_marker_id (&weak_marker_table, marker);
+      Lisp_Object offset = make_fixnum (delta);
+      Lisp_Object pair = Fcons (id, offset);
+      if (m->insertion_type)
+	left = Fcons (pair, left);
+      else
+	right = Fcons (pair, right);
+    }
+  END_DO_MARKERS;
+
+  if (!NILP (right) || !NILP (left))
+    {
+      Lisp_Object l
+	= list5 (Qapply, make_fixnum (0), make_fixnum (from),
+		 make_fixnum (to), Qundo__adjust_weak_markers);
+      Lisp_Object args = Qnil;
+      if (!NILP (right))
+	args = Fcons (make_fixnum (from), right);
+      if (!NILP (left))
+	args = Fcons (make_fixnum (-to), nconc2 (left, args));
+      Lisp_Object entry = nconc2 (l, args);
+      bset_undo_list (current_buffer,
+		      Fcons (entry,
+			     BVAR (current_buffer, undo_list)));
+    }
+
+#else
+
   DO_MARKERS (current_buffer, m)
     {
       ptrdiff_t charpos = m->charpos;
@@ -249,27 +338,15 @@ record_marker_adjustments (ptrdiff_t from, ptrdiff_t to)
           if (adjustment)
             {
 	      Lisp_Object marker = make_lisp_ptr (m, Lisp_Vectorlike);
-#ifdef HAVE_MPS
-	      Lisp_Object id
-		= alloc_weak_marker_id (&weak_marker_table, marker);
-	      Lisp_Object distance = make_fixnum (adjustment);
-	      Lisp_Object entry
-		= list5 (Qapply, Qundo__adjust_weak_marker,
-			 weak_marker_table.id_to_marker, id,
-			 distance);
-	      bset_undo_list (current_buffer,
-			      Fcons (entry, BVAR (current_buffer,
-						  undo_list)));
-#else
               bset_undo_list
                 (current_buffer,
                  Fcons (Fcons (marker, make_fixnum (adjustment)),
                         BVAR (current_buffer, undo_list)));
-#endif
             }
         }
     }
   END_DO_MARKERS;
+#endif
 }
 
 /* Record that a deletion is about to take place, of the characters in
@@ -608,11 +685,12 @@ so it must make sure not to do a lot of consing.  */);
 	       doc: /* Non-nil means do not record `point' in `buffer-undo-list'.  */);
   undo_inhibit_record_point = false;
 
-  DEFSYM (Qundo__adjust_weak_marker, "undo--adjust-weak-marker");
+  DEFSYM (Qundo__adjust_weak_markers, "undo--adjust-weak-markers");
+  defsubr (&Sundo__lookup_marker);
+  staticpro (&weak_marker_table.id_to_marker);
+  staticpro (&weak_marker_table.marker_to_id);
   weak_marker_table.id_to_marker
     = CALLN (Fmake_hash_table, QCweakness, Qvalue);
   weak_marker_table.marker_to_id
     = CALLN (Fmake_hash_table, QCweakness, Qkey);
-  staticpro (&weak_marker_table.id_to_marker);
-  staticpro (&weak_marker_table.marker_to_id);
 }

test/lisp/erc/erc-tests.el

@@ -3140,9 +3140,10 @@
              (should
               (pcase-exhaustive buffer-undo-list
                 (`(nil ("c" . -47)
-                       (apply undo--adjust-weak-marker ,ht ,id  -1)
+                       (apply 0 47 48 undo--adjust-weak-markers
+                              47 (,id . 1))
                        (nil face nil 46 . 47) 48 nil (45 . 48))
-                 (eq (gethash id ht) marker))
+                 (eq (undo--lookup-marker id) marker))
                 (`_ nil))))
             (t
              (should (equal buffer-undo-list `(nil
@@ -3167,9 +3168,10 @@
              (should
               (pcase-exhaustive buffer-undo-list
                 (`(nil ("c" . -58)
-                       (apply undo--adjust-weak-marker ,ht ,id -1)
+                       (apply 0 47 48 undo--adjust-weak-markers
+                              47 (,id . 1))
                        (nil face nil 57 . 58) 59 nil (56 . 59))
-                 (eq (gethash id ht) marker))
+                 (eq (undo--lookup-marker id) marker))
                 (`_ nil))))
             (t
              (should (equal buffer-undo-list `(nil

test/src/editfns-tests.el

@@ -677,14 +677,20 @@ sufficiently large to avoid truncation."
     ;; `garbage-collect' will also abort if it finds any reachable
     ;; freed objects.
     (cond ((featurep 'mps)
-           (dolist (i '(1 2))
+           (should (pcase-exhaustive (nth 1 buffer-undo-list)
-             (should (pcase-exhaustive (nth i buffer-undo-list)
+                     (`(apply 0 1 6 undo--adjust-weak-markers
-                       (`(apply undo--adjust-weak-marker . ,_) t)
+                              -6 (,_ . -1) 1 (,_ . 1))
-                       (`,_ nil)))))
+                      t)
+                     (`,_ nil))))
           (t
            (should (eq (type-of (car (nth 1 buffer-undo-list))) 'marker))
            (should (eq (type-of (car (nth 2 buffer-undo-list))) 'marker))))
-    (garbage-collect)))
+    (cond ((featurep 'mps)
+           (igc--collect)
+           (igc--process-messages)
+           (should (equal buffer-undo-list '(("12345" . 1)))))
+          (t
+           (garbage-collect)))))
 
 (ert-deftest delete-region-undo-markers-2 ()
   "Make sure we don't end up with freed markers reachable from Lisp."
@@ -708,14 +714,20 @@ sufficiently large to avoid truncation."
     ;; `garbage-collect' will also abort if it finds any reachable
     ;; freed objects.
     (cond ((featurep 'mps)
-           (dolist (i '(3 4))
+           (should (pcase-exhaustive (nth 2 buffer-undo-list)
-             (should (pcase-exhaustive (nth i buffer-undo-list)
+                     (`(apply 0 1 6 undo--adjust-weak-markers
-                       (`(apply undo--adjust-weak-marker . ,_) t)
+                              1 (,_ . 1) (,_ . 1) (,_ . 4))
-                       (`,_ nil)))))
+                      t)
+                     (`,_ nil))))
           (t
            (should (eq (type-of (car (nth 3 buffer-undo-list))) 'marker))
            (should (eq (type-of (car (nth 4 buffer-undo-list))) 'marker))))
-    (garbage-collect)))
+    (cond ((featurep 'mps)
+           (igc--collect)
+           (igc--process-messages)
+           (should (equal buffer-undo-list '(("678" . 1) ("12345" . 1)))))
+          (t
+           (garbage-collect)))))
 
 (ert-deftest format-bignum ()
   (let* ((s1 "FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF")