bug#26932: Found the triggering behaviour

[Vivek Dasmohapatra <vivek@etla.org>]

The old code in lui.el used to (effectively) do this:

   (setq buffer-undo-list (mapcar a-lambda-here buffer-undo-list))

This seemed to cause some strings in the undo list structure to get
freed to early, then freed again later.

The altered code uses the approach of setf'ing the relevant elements of
the undo-list, which doesn't trick the GC code into a premature free.

Since there's a workaround it's not particularly urgent, but it seems
to me that there's a hole in the GC logic somewhere.

--- /home/vivek/elisp/lui.el	2017-07-23 19:42:11.047162827 +0100
+++ /home/vivek/elisp/lui.el	2017-07-28 14:03:00.306977730 +0100
@@ -358,10 +358,8 @@
           (setq val (progn ,@body)))
         (when (consp buffer-undo-list)
           ;; Not t :-)
-         (setq buffer-undo-list (lui-adjust-undo-list buffer-undo-list
-                                                      ,old-marker-sym
-                                                      (- lui-input-marker
-                                                         ,old-marker-sym))))
+         (lui-adjust-undo-list  ,old-marker-sym (- lui-input-marker
+                                                   ,old-marker-sym)))
         val)))


@@ -776,66 +774,47 @@
                                    faces)))))))
    )

-(defun lui-adjust-undo-list (list old-begin shift)
-  "Adjust undo positions in LIST by SHIFT.
-LIST is in the format of `buffer-undo-list'.
-Only positions after OLD-BEGIN are affected."
-  ;; This is necessary because the undo-list keeps exact buffer
-  ;; positions.
-  ;; Thanks to ERC for the idea of the code.
-  ;; ERC's code doesn't take care of an OLD-BEGIN value, which is
-  ;; necessary if you allow modification of the buffer.
-  (let* ((adjust-position (lambda (pos)
-                            (if (and (numberp pos)
-                                     ;; After the boundary: Adjust
-                                     (>= (abs pos)
-                                         old-begin))
-                                (* (if (< pos 0)
-                                       -1
-                                     1)
-                                   (+ (abs pos)
-                                      shift))
-                              pos)))
-         (adjust (lambda (entry)
-                   (cond
-                    ;; POSITION
-                    ((numberp entry)
-                     (funcall adjust-position entry))
-                    ((not (consp entry))
-                     entry)
-                    ;; (BEG . END)
-                    ((numberp (car entry))
-                     (cons (funcall adjust-position (car entry))
-                           (funcall adjust-position (cdr entry))))
-                    ;; (TEXT . POSITION)
-                    ((stringp (car entry))
-                     (cons (car entry)
-                           (funcall adjust-position (cdr entry))))
-                    ;; (nil PROPERTY VALUE BEG . END)
-                    ((not (car entry))
-                     `(nil ,(nth 1 entry)
-                           ,(nth 2 entry)
-                           ,(funcall adjust-position (nth 3 entry))
-                           .
-                           ,(funcall adjust-position (nthcdr 4 entry))))
-                    ;; (apply DELTA BEG END FUN-NAME . ARGS)
-                    ((and (eq 'apply (car entry))
-                          (numberp (cadr entry)))
-                     `(apply ,(nth 1 entry)
-                             ,(funcall adjust-position (nth 2 entry))
-                             ,(funcall adjust-position (nth 3 entry))
-                             ,(nth 4 entry)
-                             .
-                             ,(nthcdr 5 entry)))
-                    ;; XEmacs: (<extent> start end)
-                    ((and (fboundp 'extentp)
-                          (extentp (car entry)))
-                     (list (nth 0 entry)
-                           (funcall adjust-position (nth 1 entry))
-                           (funcall adjust-position (nth 2 entry))))
-                    (t
-                     entry)))))
-    (mapcar adjust list)))
+;; ----------------------------------------------------------------------------
+
+(defun lui--adjust-p (pos old)
+  (and (numberp pos) (>= (abs pos) old)))
+
+(defun lui--new-pos (pos shift)
+  (* (if (< pos 0) -1 1) (+ (abs pos) shift)))
+
+(defun lui-adjust-undo-list (old-begin shift)
+  ;; Translate buffer positions in buffer-undo-list by SHIFT.
+  (unless (or (zerop shift) (atom buffer-undo-list))
+    (let ((list buffer-undo-list) elt)
+      (while list
+        (setq elt (car list))
+        (cond ((integerp elt)           ; POSITION
+               (if (lui--adjust-p elt old-begin)
+                   (setf (car list) (lui--new-pos elt shift))))
+              ((or (atom elt)           ; nil, EXTENT
+                   (markerp (car elt))) ; (MARKER . DISTANCE)
+               nil)
+              ((integerp (car elt))     ; (BEGIN . END)
+               (if (lui--adjust-p (car elt) old-begin)
+                   (setf (car elt) (lui--new-pos (car elt) shift)))
+               (if (lui--adjust-p (cdr elt) old-begin)
+                   (setf (cdr elt) (lui--new-pos (cdr elt) shift))))
+              ((stringp (car elt))      ; (TEXT . POSITION)
+               (if (lui--adjust-p (cdr elt) old-begin)
+                   (setf (cdr elt) (lui--new-pos (cdr elt) shift))))
+              ((null (car elt))         ; (nil PROPERTY VALUE BEG . END)
+               (let ((cons (nthcdr 3 elt)))
+                 (if (lui--adjust-p (car cons) old-begin)
+                     (setf (car cons) (lui--new-pos (car cons) shift)))
+                 (if (lui--adjust-p (cdr cons) old-begin)
+                     (setf (cdr cons) (lui--new-pos (cdr cons) shift)))))
+              ((and (featurep 'xemacs)
+                    (extentp (car elt))) ; (EXTENT START END)
+               (if (lui--adjust-p (nth 1 elt) old-begin)
+                     (setf (nth 1 elt) (lui--new-pos (nth 1 elt) shift)))
+                 (if (lui--adjust-p (nth 2 elt) old-begin)
+                     (setf (nth 2 elt) (lui--new-pos (nth 2 elt) shift)))))
+        (setq list (cdr list))))))

  (defvar lui-prompt-map
    (let ((map (make-sparse-keymap)))