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.