bug#16411: undo-only bugs

[Barry OReilly <gundaetiapo@gmail.com>]

[-- Attachment #1.1: Type: text/plain, Size: 601 bytes --]

I have attached a patch against trunk which omits the generators,
changes the data format of pending-undo-list, and addresses other
comments. The undo-tests pass with this patch. As with the last
patch, it doesn't solve an actual bug yet, but that is
forthcoming.

Since undo-tree uses primitive-undo, I think it must remain
compatible. To do this and not duplicate code, I split individual
element logic out to an undo-primitive-elt function and moved the
look ahead at marker adjustments to undo-more. Since the latter
is recent functionality, I doubt undo-tree relies on
primitive-undo doing that.

[-- Attachment #1.2: Type: text/html, Size: 672 bytes --]

[-- Attachment #2: undone-undos.diff --]
[-- Type: text/plain, Size: 24516 bytes --]

diff --git a/lisp/simple.el b/lisp/simple.el
index af8e47c..9b47ccb 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -2054,20 +2054,50 @@ Go to the history element by the absolute history position HIST-POS."
 ;Put this on C-x u, so we can force that rather than C-_ into startup msg
 (define-obsolete-function-alias 'advertised-undo 'undo "23.2")
 
+;; Note: We considered a design whereby one entry in the
+;; undo-redo-table maps a change group to a list of undone elements or
+;; groups.  This design does not work because the value stored in
+;; undo-redo-table would need to be a non weak list with weak
+;; references into buffer-undo-list.  Currently Elisp only features
+;; weak references when they are directly keys or values of a weak
+;; hash table, so a list containing weak references is not supported.
+(defvar undo-redo-table (make-hash-table :test 'eq :weakness t)
+  "Hash table mapping undos to what they undid.
+
+Specifically, the keys and values are eq to a cons of
+buffer-undo-list such that the car of the key is an undo element
+and the car of the value is the undone element.
+
+The hash table is weak so as truncated undo elements can be
+garbage collected.")
 (defconst undo-equiv-table (make-hash-table :test 'eq :weakness t)
   "Table mapping redo records to the corresponding undo one.
 A redo record for undo-in-region maps to t.
 A redo record for ordinary undo maps to the following (earlier) undo.")
+(make-obsolete-variable
+ 'undo-equiv-table
+ "Use undo-redo-table instead.  For non regional undos, (gethash
+k undo-equiv-table) is the same as taking (gethash k
+undo-redo-table) and scanning forward one change group."
+ "24.5")
 
 (defvar undo-in-region nil
-  "Non-nil if `pending-undo-list' is not just a tail of `buffer-undo-list'.")
+  "Non-nil during an undo in region.")
 
 (defvar undo-no-redo nil
   "If t, `undo' doesn't go through redo entries.")
 
 (defvar pending-undo-list nil
-  "Within a run of consecutive undo commands, list remaining to be undone.
-If t, we undid all the way to the end of it.")
+  "The pending undo elements in a run of consecutive undo commands.
+
+Specifically, this is a list of assocations of the
+form (ADJUSTED-ELT . ORIG-UNDO-LIST).  ADJUSTED-ELT is an undo
+element with adjusted positions and ORIG-UNDO-LIST is a cons of
+buffer-undo-list whose car is the original unadjusted undo
+element.  ADJUSTED-ELT may or may not be eq to (car
+ORIG-UNDO-LIST).
+
+If t, there is no more to undo.")
 
 (defun undo (&optional arg)
   "Undo some previous changes.
@@ -2115,9 +2145,8 @@ as an argument limits undo to changes within the current region."
       (undo-more 1))
     ;; If we got this far, the next command should be a consecutive undo.
     (setq this-command 'undo)
-    ;; Check to see whether we're hitting a redo record, and if
-    ;; so, ask the user whether she wants to skip the redo/undo pair.
-    (let ((equiv (gethash pending-undo-list undo-equiv-table)))
+    ;; Check to see whether we're hitting a redo record
+    (let ((equiv (gethash (cdr-safe pending-undo-list) undo-equiv-table)))
       (or (eq (selected-window) (minibuffer-window))
 	  (setq message (format "%s%s!"
                                 (if (or undo-no-redo (not equiv))
@@ -2128,7 +2157,7 @@ as an argument limits undo to changes within the current region."
 	;; undo-redo-undo-redo-... so skip to the very last equiv.
 	(while (let ((next (gethash equiv undo-equiv-table)))
 		 (if next (setq equiv next))))
-	(setq pending-undo-list equiv)))
+	(setq pending-undo-list (cons (car equiv) equiv))))
     (undo-more
      (if (numberp arg)
 	 (prefix-numeric-value arg)
@@ -2138,18 +2167,20 @@ as an argument limits undo to changes within the current region."
     ;; In the ordinary case (not within a region), map the redo
     ;; record to the following undos.
     ;; I don't know how to do that in the undo-in-region case.
-    (let ((list buffer-undo-list))
+    (let ((list buffer-undo-list)
+          (new-equiv (cdr-safe pending-undo-list)))
       ;; Strip any leading undo boundaries there might be, like we do
       ;; above when checking.
       (while (eq (car list) nil)
 	(setq list (cdr list)))
-      (puthash list
-               ;; Prevent identity mapping.  This can happen if
-               ;; consecutive nils are erroneously in undo list.
-               (if (or undo-in-region (eq list pending-undo-list))
-                   t
-                 pending-undo-list)
-	       undo-equiv-table))
+      (when new-equiv
+        (puthash list
+                 ;; Prevent identity mapping.  This can happen if
+                 ;; consecutive nils are erroneously in undo list.
+                 (if (or undo-in-region (eq list new-equiv))
+                     t
+                   new-equiv)
+                 undo-equiv-table)))
     ;; Don't specify a position in the undo record for the undo command.
     ;; Instead, undoing this should move point to where the change is.
     (let ((tail buffer-undo-list)
@@ -2202,145 +2233,152 @@ Some change-hooks test this variable to do something different.")
   "Undo back N undo-boundaries beyond what was already undone recently.
 Call `undo-start' to get ready to undo recent changes,
 then call `undo-more' one or more times to undo them."
-  (or (listp pending-undo-list)
-      (user-error (concat "No further undo information"
-                          (and undo-in-region " for region"))))
-  (let ((undo-in-progress t))
-    ;; Note: The following, while pulling elements off
-    ;; `pending-undo-list' will call primitive change functions which
-    ;; will push more elements onto `buffer-undo-list'.
-    (setq pending-undo-list (primitive-undo n pending-undo-list))
-    (if (null pending-undo-list)
-	(setq pending-undo-list t))))
+  (when (eq pending-undo-list t)
+    (user-error (concat "No further undo information"
+                        (and undo-in-region " for region"))))
+  (let ((undo-in-progress t)
+        (group n)
+        assoc)
+    (while (> group 0)
+      (while (car (setq assoc (pop pending-undo-list)))
+        (let ((elt (car assoc))
+              (orig-tail (cdr assoc))
+              valid-marker-adjustments)
+          (when (and (stringp (car-safe elt))
+                     (integerp (cdr-safe elt)))
+            ;; Check that marker adjustments which were recorded with
+            ;; the (STRING . POS) record are still valid, ie the
+            ;; markers haven't moved.  We check their validity before
+            ;; reinserting the string so as we don't need to mind
+            ;; marker insertion-type.
+            (while (and (markerp (car-safe (caar pending-undo-list)))
+                        (integerp (cdr-safe (caar pending-undo-list))))
+              (let* ((marker-adj (car (pop pending-undo-list)))
+                     (m (car marker-adj)))
+                (and (eq (marker-buffer m) (current-buffer))
+                     (= (cdr elt) m)
+                     (push marker-adj valid-marker-adjustments)))))
+          (when (markerp (car-safe elt))
+            ;; Note: even though these elements are not expected in
+            ;; the undo list, adjust them to be conservative for the
+            ;; 24.4 release.  (Bug#16818)
+            (warn "Encountered %S entry in undo list with no matching (TEXT . POS) entry"
+                  elt))
+          ;; Note: The following changes the buffer, and so calls
+          ;; primitive change functions that push more elements onto
+          ;; `buffer-undo-list'.
+          (when (undo-primitive-elt elt)
+            ;; Map the new undo element to what it undid.  Not aware
+            ;; yet of cases where we want to map all new elements.
+            (puthash buffer-undo-list orig-tail undo-redo-table))
+          ;; Adjust the valid marker adjustments
+          (dolist (adj valid-marker-adjustments)
+            (undo-primitive-elt adj))))
+      (setq group (1- group)))
+    ;; Reached the end of undo history
+    (unless pending-undo-list (setq pending-undo-list t))))
 
 (defun primitive-undo (n list)
-  "Undo N records from the front of the list LIST.
+  "Undo N change groups from the front of the list LIST.
 Return what remains of the list."
+  (let ((arg n)
+        (next nil))
+    (while (> arg 0)
+      (while (setq next (pop list))     ;Exit inner loop at undo boundary.
+        (undo-primitive-elt next))
+      (setq arg (1- arg)))))
 
-  ;; This is a good feature, but would make undo-start
-  ;; unable to do what is expected.
-  ;;(when (null (car (list)))
-  ;;  ;; If the head of the list is a boundary, it is the boundary
-  ;;  ;; preceding this command.  Get rid of it and don't count it.
-  ;;  (setq list (cdr list))))
+(defun undo-primitive-elt (next)
+  "Undo the element NEXT and return non nil if changes were made.
 
-  (let ((arg n)
-        ;; In a writable buffer, enable undoing read-only text that is
+NEXT is one of the valid forms documented in the Undo section of
+the Elisp manual."
+  (let (;; In a writable buffer, enable undoing read-only text that is
         ;; so because of text properties.
         (inhibit-read-only t)
         ;; Don't let `intangible' properties interfere with undo.
         (inhibit-point-motion-hooks t)
         ;; We use oldlist only to check for EQ.  ++kfs
-        (oldlist buffer-undo-list)
-        (did-apply nil)
-        (next nil))
-    (while (> arg 0)
-      (while (setq next (pop list))     ;Exit inner loop at undo boundary.
-        ;; Handle an integer by setting point to that value.
-        (pcase next
-          ((pred integerp) (goto-char next))
-          ;; Element (t . TIME) records previous modtime.
-          ;; Preserve any flag of NONEXISTENT_MODTIME_NSECS or
-          ;; UNKNOWN_MODTIME_NSECS.
-          (`(t . ,time)
-           ;; If this records an obsolete save
-           ;; (not matching the actual disk file)
-           ;; then don't mark unmodified.
-           (when (or (equal time (visited-file-modtime))
-                     (and (consp time)
-                          (equal (list (car time) (cdr time))
-                                 (visited-file-modtime))))
-             (when (fboundp 'unlock-buffer)
-               (unlock-buffer))
-             (set-buffer-modified-p nil)))
-          ;; Element (nil PROP VAL BEG . END) is property change.
-          (`(nil . ,(or `(,prop ,val ,beg . ,end) pcase--dontcare))
-           (when (or (> (point-min) beg) (< (point-max) end))
-             (error "Changes to be undone are outside visible portion of buffer"))
-           (put-text-property beg end prop val))
-          ;; Element (BEG . END) means range was inserted.
-          (`(,(and beg (pred integerp)) . ,(and end (pred integerp)))
-           ;; (and `(,beg . ,end) `(,(pred integerp) . ,(pred integerp)))
-           ;; Ideally: `(,(pred integerp beg) . ,(pred integerp end))
-           (when (or (> (point-min) beg) (< (point-max) end))
-             (error "Changes to be undone are outside visible portion of buffer"))
-           ;; Set point first thing, so that undoing this undo
-           ;; does not send point back to where it is now.
-           (goto-char beg)
-           (delete-region beg end))
-          ;; Element (apply FUN . ARGS) means call FUN to undo.
-          (`(apply . ,fun-args)
-           (let ((currbuff (current-buffer)))
-             (if (integerp (car fun-args))
-                 ;; Long format: (apply DELTA START END FUN . ARGS).
-                 (pcase-let* ((`(,delta ,start ,end ,fun . ,args) fun-args)
-                              (start-mark (copy-marker start nil))
-                              (end-mark (copy-marker end t)))
-                   (when (or (> (point-min) start) (< (point-max) end))
-                     (error "Changes to be undone are outside visible portion of buffer"))
-                   (apply fun args) ;; Use `save-current-buffer'?
-                   ;; Check that the function did what the entry
-                   ;; said it would do.
-                   (unless (and (= start start-mark)
-                                (= (+ delta end) end-mark))
-                     (error "Changes to be undone by function different than announced"))
-                   (set-marker start-mark nil)
-                   (set-marker end-mark nil))
-               (apply fun-args))
-             (unless (eq currbuff (current-buffer))
-               (error "Undo function switched buffer"))
-             (setq did-apply t)))
-          ;; Element (STRING . POS) means STRING was deleted.
-          (`(,(and string (pred stringp)) . ,(and pos (pred integerp)))
-           (when (let ((apos (abs pos)))
-                   (or (< apos (point-min)) (> apos (point-max))))
-             (error "Changes to be undone are outside visible portion of buffer"))
-           (let (valid-marker-adjustments)
-             ;; Check that marker adjustments which were recorded
-             ;; with the (STRING . POS) record are still valid, ie
-             ;; the markers haven't moved.  We check their validity
-             ;; before reinserting the string so as we don't need to
-             ;; mind marker insertion-type.
-             (while (and (markerp (car-safe (car list)))
-                         (integerp (cdr-safe (car list))))
-               (let* ((marker-adj (pop list))
-                      (m (car marker-adj)))
-                 (and (eq (marker-buffer m) (current-buffer))
-                      (= pos m)
-                      (push marker-adj valid-marker-adjustments))))
-             ;; Insert string and adjust point
-             (if (< pos 0)
-                 (progn
-                   (goto-char (- pos))
-                   (insert string))
-               (goto-char pos)
-               (insert string)
-               (goto-char pos))
-             ;; Adjust the valid marker adjustments
-             (dolist (adj valid-marker-adjustments)
-               (set-marker (car adj)
-                           (- (car adj) (cdr adj))))))
-          ;; (MARKER . OFFSET) means a marker MARKER was adjusted by OFFSET.
-          (`(,(and marker (pred markerp)) . ,(and offset (pred integerp)))
-           (warn "Encountered %S entry in undo list with no matching (TEXT . POS) entry"
-                 next)
-           ;; Even though these elements are not expected in the undo
-           ;; list, adjust them to be conservative for the 24.4
-           ;; release.  (Bug#16818)
-           (when (marker-buffer marker)
-             (set-marker marker
-                         (- marker offset)
-                         (marker-buffer marker))))
-          (_ (error "Unrecognized entry in undo list %S" next))))
-      (setq arg (1- arg)))
-    ;; Make sure an apply entry produces at least one undo entry,
-    ;; so the test in `undo' for continuing an undo series
-    ;; will work right.
-    (if (and did-apply
-             (eq oldlist buffer-undo-list))
-        (setq buffer-undo-list
-              (cons (list 'apply 'cdr nil) buffer-undo-list))))
-  list)
+        (oldlist buffer-undo-list))
+    ;; Handle an integer by setting point to that value.
+    (pcase next
+      ((pred integerp) (goto-char next))
+      ;; Element (t . TIME) records previous modtime.
+      ;; Preserve any flag of NONEXISTENT_MODTIME_NSECS or
+      ;; UNKNOWN_MODTIME_NSECS.
+      (`(t . ,time)
+       ;; If this records an obsolete save
+       ;; (not matching the actual disk file)
+       ;; then don't mark unmodified.
+       (when (or (equal time (visited-file-modtime))
+                 (and (consp time)
+                      (equal (list (car time) (cdr time))
+                             (visited-file-modtime))))
+         (when (fboundp 'unlock-buffer)
+           (unlock-buffer))
+         (set-buffer-modified-p nil)))
+      ;; Element (nil PROP VAL BEG . END) is property change.
+      (`(nil . ,(or `(,prop ,val ,beg . ,end) pcase--dontcare))
+       (when (or (> (point-min) beg) (< (point-max) end))
+         (error "Changes to be undone are outside visible portion of buffer"))
+       (put-text-property beg end prop val))
+      ;; Element (BEG . END) means range was inserted.
+      (`(,(and beg (pred integerp)) . ,(and end (pred integerp)))
+       ;; (and `(,beg . ,end) `(,(pred integerp) . ,(pred integerp)))
+       ;; Ideally: `(,(pred integerp beg) . ,(pred integerp end))
+       (when (or (> (point-min) beg) (< (point-max) end))
+         (error "Changes to be undone are outside visible portion of buffer"))
+       ;; Set point first thing, so that undoing this undo
+       ;; does not send point back to where it is now.
+       (goto-char beg)
+       (delete-region beg end))
+      ;; Element (apply FUN . ARGS) means call FUN to undo.
+      (`(apply . ,fun-args)
+       (let ((currbuff (current-buffer)))
+         (if (integerp (car fun-args))
+             ;; Long format: (apply DELTA START END FUN . ARGS).
+             (pcase-let* ((`(,delta ,start ,end ,fun . ,args) fun-args)
+                          (start-mark (copy-marker start nil))
+                          (end-mark (copy-marker end t)))
+               (when (or (> (point-min) start) (< (point-max) end))
+                 (error "Changes to be undone are outside visible portion of buffer"))
+               (apply fun args) ;; Use `save-current-buffer'?
+               ;; Check that the function did what the entry
+               ;; said it would do.
+               (unless (and (= start start-mark)
+                            (= (+ delta end) end-mark))
+                 (error "Changes to be undone by function different than announced"))
+               (set-marker start-mark nil)
+               (set-marker end-mark nil))
+           (apply fun-args))
+         (unless (eq currbuff (current-buffer))
+           (error "Undo function switched buffer"))
+         ;; Make sure an apply entry produces at least one undo entry,
+         ;; so the test in `undo' for continuing an undo series
+         ;; will work right.
+         (when (eq oldlist buffer-undo-list)
+           (push (list 'apply 'cdr nil) buffer-undo-list))))
+      ;; Element (STRING . POS) means STRING was deleted.
+      (`(,(and string (pred stringp)) . ,(and pos (pred integerp)))
+       (when (let ((apos (abs pos)))
+               (or (< apos (point-min)) (> apos (point-max))))
+         (error "Changes to be undone are outside visible portion of buffer"))
+       ;; Insert string and adjust point
+       (if (< pos 0)
+           (progn
+             (goto-char (- pos))
+             (insert string))
+         (goto-char pos)
+         (insert string)
+         (goto-char pos)))
+      ;; (MARKER . OFFSET) means a marker MARKER was adjusted by OFFSET.
+      (`(,(and marker (pred markerp)) . ,(and offset (pred integerp)))
+       (when (marker-buffer marker)
+         (set-marker marker
+                     (- marker offset)
+                     (marker-buffer marker))))
+      (_ (error "Unrecognized entry in undo list %S" next)))
+    (not (eq oldlist buffer-undo-list))))
 
 ;; Deep copy of a list
 (defun undo-copy-list (list)
@@ -2353,17 +2391,22 @@ Return what remains of the list."
     elt))
 
 (defun undo-start (&optional beg end)
-  "Set `pending-undo-list' to the front of the undo list.
-The next call to `undo-more' will undo the most recently made change.
-If BEG and END are specified, then only undo elements
-that apply to text between BEG and END are used; other undo elements
-are ignored.  If BEG and END are nil, all undo elements are used."
+  "Set `pending-undo-list' to begin a run of undos.  The next
+call to `undo-more' will undo the next change group.  If BEG and
+END are specified, then only undo elements that apply to text
+between BEG and END are used; other undo elements are ignored.
+If BEG and END are nil, all undo elements are used."
   (if (eq buffer-undo-list t)
       (user-error "No undo information in this buffer"))
   (setq pending-undo-list
 	(if (and beg end (not (= beg end)))
-	    (undo-make-selective-list (min beg end) (max beg end))
-	  buffer-undo-list)))
+	    (undo-make-regional-list (min beg end) (max beg end))
+          (let ((list-i buffer-undo-list)
+                assoc-list)
+            (while list-i
+              (push (cons (car list-i) list-i) assoc-list)
+              (pop list-i))
+            (nreverse assoc-list)))))
 
 ;; The positions given in elements of the undo list are the positions
 ;; as of the time that element was recorded to undo history.  In
@@ -2424,15 +2467,17 @@ are ignored.  If BEG and END are nil, all undo elements are used."
 ;; "ccaabad", as though the first "d" became detached from the
 ;; original "ddd" insertion.  This quirk is a FIXME.
 
-(defun undo-make-selective-list (start end)
-  "Return a list of undo elements for the region START to END.
-The elements come from `buffer-undo-list', but we keep only the
-elements inside this region, and discard those outside this
-region.  The elements' positions are adjusted so as the returned
-list can be applied to the current buffer."
+(defun undo-make-regional-list (start end)
+  "Return a list of undo associations for the region START to END,
+
+The undo associations are of the form (ADJUSTED-ELT
+. ORIG-UNDO-LIST) and are as documented for
+pending-undo-list. Only associations for elements lying inside
+the region are included. Their positions are adjusted based on
+the discarded elements not fully in the region."
   (let ((ulist buffer-undo-list)
-        ;; A list of position adjusted undo elements in the region.
-        (selective-list (list nil))
+        ;; The list of (ADJUSTED-ELT . ORIG-UNDO-LIST) to return
+        (selective-list (list (cons nil nil)))
         ;; A list of undo-deltas for out of region undo elements.
         undo-deltas
         undo-elt)
@@ -2443,14 +2488,16 @@ list can be applied to the current buffer."
       (setq undo-elt (car ulist))
       (cond
        ((null undo-elt)
-        ;; Don't put two nils together in the list
-        (when (car selective-list)
-          (push nil selective-list)))
+        (let (;; Undo boundary representation
+              (boundary (cons nil nil)))
+          ;; Don't put two undo boundaries together in the list
+          (unless (equal boundary (car selective-list))
+            (push boundary selective-list))))
        ((and (consp undo-elt) (eq (car undo-elt) t))
         ;; This is a "was unmodified" element.  Keep it
         ;; if we have kept everything thus far.
         (when (not undo-deltas)
-          (push undo-elt selective-list)))
+          (push (cons undo-elt ulist) selective-list)))
        ;; Skip over marker adjustments, instead relying
        ;; on finding them after (TEXT . POS) elements
        ((markerp (car-safe undo-elt))
@@ -2461,20 +2508,30 @@ list can be applied to the current buffer."
           (if (undo-elt-in-region adjusted-undo-elt start end)
               (progn
                 (setq end (+ end (cdr (undo-delta adjusted-undo-elt))))
-                (push adjusted-undo-elt selective-list)
+                (push (cons adjusted-undo-elt ulist) selective-list)
                 ;; Keep (MARKER . ADJUSTMENT) if their (TEXT . POS) was
                 ;; kept.  primitive-undo may discard them later.
                 (when (and (stringp (car-safe adjusted-undo-elt))
                            (integerp (cdr-safe adjusted-undo-elt)))
                   (let ((list-i (cdr ulist)))
                     (while (markerp (car-safe (car list-i)))
-                      (push (pop list-i) selective-list)))))
+                      (let ((marker-adj (pop list-i)))
+                        (push (cons marker-adj marker-adj)
+                              selective-list))))))
             (let ((delta (undo-delta undo-elt)))
               (when (/= 0 (cdr delta))
                 (push delta undo-deltas)))))))
       (pop ulist))
     (nreverse selective-list)))
 
+(defun undo-make-selective-list (start end)
+  "Realize a full selective undo list per
+undo-make-regional-generator."
+  (mapcar #'car (undo-make-regional-list start end)))
+(make-obsolete 'undo-make-selective-list
+               "Use undo-make-regional-list instead."
+               "24.5")
+
 (defun undo-elt-in-region (undo-elt start end)
   "Determine whether UNDO-ELT falls inside the region START ... END.
 If it crosses the edge, we return nil.