Implement selective undo (by Paul Flinders).

(undo-copy-list, undo-copy-list-1): New functions.
(undo-make-selective-list, undo-delta): New functions.
(undo-elt-in-region, undo-elt-crosses-region): New functions.
(undo-adjusted-markers): New defvar.
(undo-start): New args BEG and END.
(undo): If arg or active region, pass args to undo-start.

1 files changed, 174 insertions, 13 deletions

diff --git a/lisp/simple.el b/lisp/simple.el
index 62a6ea2e87..be60e3c8f7 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -797,8 +797,12 @@ Get previous element of history which is a completion of minibuffer contents."
 (defun undo (&optional arg)
   "Undo some previous changes.
 Repeat this command to undo more changes.
-A numeric argument serves as a repeat count."
-  (interactive "*p")
+A numeric argument serves as a repeat count.
+
+Just C-u as argument requests selective undo,
+limited to changes within the current region.
+Likewise in Transient Mark mode when the mark is active."
+  (interactive "*P")
   ;; If we don't get all the way thru, make last-command indicate that
   ;; for the following command.
   (setq this-command t)
@@ -807,9 +811,11 @@ A numeric argument serves as a repeat count."
     (or (eq (selected-window) (minibuffer-window))
 	(message "Undo!"))
     (or (eq last-command 'undo)
-	(progn (undo-start)
+	(progn (if (or arg (and transient-mark-mode mark-active))
+		   (undo-start (region-beginning) (region-end))
+		 (undo-start))
 	       (undo-more 1)))
-    (undo-more (or arg 1))
+    (undo-more (if arg (prefix-numeric-value arg) 1))
     ;; 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)
@@ -828,13 +834,6 @@ A numeric argument serves as a repeat count."
 (defvar pending-undo-list nil
   "Within a run of consecutive undo commands, list remaining to be undone.")
 
-(defun undo-start ()
-  "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 (eq buffer-undo-list t)
-      (error "No undo information in this buffer"))
-  (setq pending-undo-list buffer-undo-list))
-
 (defun undo-more (count)
   "Undo back N undo-boundaries beyond what was already undone recently.
 Call `undo-start' to get ready to undo recent changes,
@@ -843,6 +842,168 @@ then call `undo-more' one or more times to undo them."
       (error "No further undo information"))
   (setq pending-undo-list (primitive-undo count pending-undo-list)))
 
+;; Deep copy of a list
+(defun undo-copy-list (list)
+  "Make a copy of undo list LIST."
+  (mapcar 'undo-copy-list-1 list))
+
+(defun undo-copy-list-1 (elt)
+  (if (consp elt)
+      (cons (car elt) (undo-copy-list-1 (cdr elt)))
+    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."
+  (if (eq buffer-undo-list t)
+      (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)))
+
+(defvar undo-adjusted-markers)
+
+(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.
+If we find an element that crosses an edge of this region,
+we stop and ignore all further elements."
+  (let ((undo-list-copy (undo-copy-list buffer-undo-list))
+	(undo-list (list nil))
+	undo-adjusted-markers
+	some-rejected
+	undo-elt undo-elt temp-undo-list delta)
+    (while undo-list-copy
+      (setq undo-elt (car undo-list-copy))
+      (let ((keep-this
+	     (cond ((and (consp undo-elt) (eq (car undo-elt) t))
+		    ;; This is a "was unmodified" element.
+		    ;; Keep it if we have kept everything thus far.
+		    (not some-rejected))
+		   (t
+		    (undo-elt-in-region undo-elt start end)))))
+	(if keep-this
+	    (progn
+	      (setq end (+ end (cdr (undo-delta undo-elt))))
+	      ;; Don't put two nils together in the list
+	      (if (not (and (eq (car undo-list) nil)
+			    (eq undo-elt nil)))
+		  (setq undo-list (cons undo-elt undo-list))))
+	  (if (undo-elt-crosses-region undo-elt start end)
+	      (setq undo-list-copy nil)
+	    (setq some-rejected t)
+	    (setq temp-undo-list (cdr undo-list-copy))
+	    (setq delta (undo-delta undo-elt))
+
+	    (when (/= (cdr delta) 0)
+	      (let ((position (car delta))
+		    (offset (cdr delta)))
+
+		;; Loop down the earlier events adjusting their buffer positions
+		;; to reflect the fact that a change to the buffer isn't being
+		;; undone. We only need to process those element types which
+		;; undo-elt-in-region will return as being in the region since
+		;; only those types can ever get into the output
+
+		(while temp-undo-list
+		  (setq undo-elt (car temp-undo-list))
+		  (cond ((integerp undo-elt)
+			 (if (>= undo-elt position)
+			     (setcar temp-undo-list (- undo-elt offset))))
+			((atom undo-elt) nil)
+			((stringp (car undo-elt))
+			 ;; (TEXT . POSITION)
+			 (let ((text-pos (abs (cdr undo-elt)))
+			       (point-at-end (< (cdr undo-elt) 0 )))
+			   (if (>= text-pos position)
+			       (setcdr undo-elt (* (if point-at-end -1 1) 
+						   (- text-pos offset))))))
+			((integerp (car undo-elt))
+			 ;; (BEGIN . END)
+			 (when (>= (car undo-elt) position)
+			   (setcar undo-elt (- (car undo-elt) offset))
+			   (setcdr undo-elt (- (cdr undo-elt) offset))))
+			((null (car undo-elt))
+			 ;; (nil PROPERTY VALUE BEG . END)
+			 (let ((tail (nthcdr 3 undo-elt)))
+			   (when (>= (car tail) position)
+			     (setcar tail (- (car tail) offset))
+			     (setcdr tail (- (cdr tail) offset))))))
+		  (setq temp-undo-list (cdr temp-undo-list))))))))
+      (setq undo-list-copy (cdr undo-list-copy)))
+    (nreverse undo-list)))
+
+(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."
+  (cond ((integerp undo-elt)
+	 (and (>= undo-elt start)
+	      (<  undo-elt end)))
+	((eq undo-elt nil)
+	 t)
+	((atom undo-elt)
+	 nil)
+	((stringp (car undo-elt))
+	 ;; (TEXT . POSITION)
+	 (and (>= (abs (cdr undo-elt)) start)
+	      (< (abs (cdr undo-elt)) end)))
+	((and (consp undo-elt) (markerp (car undo-elt)))
+	 ;; This is a marker-adjustment element (MARKER . ADJUSTMENT).
+	 ;; See if MARKER is inside the region.
+	 (let ((alist-elt (assq (car undo-elt) undo-adjusted-markers)))
+	   (unless alist-elt
+	     (setq alist-elt (cons (car undo-elt)
+				   (marker-position (car undo-elt))))
+	     (setq undo-adjusted-markers
+		   (cons alist-elt undo-adjusted-markers)))
+	   (and (cdr alist-elt)
+		(>= (cdr alist-elt) start)
+		(< (cdr alist-elt) end))))
+	((null (car undo-elt))
+	 ;; (nil PROPERTY VALUE BEG . END)
+	 (let ((tail (nthcdr 3 undo-elt)))
+	   (and (>= (car tail) start)
+		(< (cdr tail) end))))
+	((integerp (car undo-elt))
+	 ;; (BEGIN . END)
+	 (and (>= (car undo-elt) start)
+	      (< (cdr undo-elt) end)))))
+
+(defun undo-elt-crosses-region (undo-elt start end)
+  "Test whether UNDO-ELT crosses one edge of that region START ... END.
+This assumes we have already decided that UNDO-ELT
+is not *inside* the region START...END."
+  (cond ((atom undo-elt) nil)
+	((null (car undo-elt))
+	 ;; (nil PROPERTY VALUE BEG . END)
+	 (let ((tail (nthcdr 3 undo-elt)))
+	   (not (or (< (car tail) end)
+		    (> (cdr tail) start)))))
+	((integerp (car undo-elt))
+	 ;; (BEGIN . END)
+	 (not (or (< (car undo-elt) end)
+		  (> (cdr undo-elt) start))))))
+
+;; Return the first affected buffer position and the delta for an undo element
+;; delta is defined as the change in subsequent buffer positions if we *did*
+;; the undo.
+(defun undo-delta (undo-elt)
+  (if (consp undo-elt)
+      (cond ((stringp (car undo-elt))
+	     ;; (TEXT . POSITION)
+	     (cons (abs (cdr undo-elt)) (length (car undo-elt))))
+	    ((integerp (car undo-elt))
+	     ;; (BEGIN . END)
+	     (cons (car undo-elt) (- (car undo-elt) (cdr undo-elt))))
+	    (t
+	     '(0 . 0)))
+    '(0 . 0)))
+
 (defvar shell-command-history nil
   "History list for some commands that read shell commands.")
 
@@ -934,7 +1095,7 @@ In either case, the output is inserted after point (leaving mark after it)."
 		  ))
 	    (shell-command-on-region (point) (point) command output-buffer)
 	    ))))))
-
+
 ;; We have a sentinel to prevent insertion of a termination message
 ;; in the buffer itself.
 (defun shell-command-sentinel (process signal)
@@ -1072,7 +1233,7 @@ If it is nil, error output is mingled with regular output."
   (if (and error-file (file-exists-p error-file))
       (save-excursion
 	(set-buffer (get-buffer-create error-buffer))
-    ;; Do no formatting while reading error file, for fear of looping.
+	;; Do no formatting while reading error file, for fear of looping.
 	(format-insert-file error-file nil)
 	(delete-file error-file)))))