scratch/igc/weak-undo-list c09d1f61c96: Change the format for adjust-marker entries in the undo-list
Helmut Eller <[email protected]>
| Newsgroups | gmane.emacs.diffs |
|---|---|
| Message-ID | <[email protected]> |
branch: scratch/igc/weak-undo-list commit c09d1f61c96b8c2c6cb44ecafab929d741fe6495 Author: Helmut Eller <[email protected]> Commit: Helmut Eller <[email protected]> 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 | 39 ++++++++++----- src/undo.c | 116 +++++++++++++++++++++++++++++++++++++-------- test/lisp/erc/erc-tests.el | 10 ++-- test/src/editfns-tests.el | 32 +++++++++---- 4 files changed, 152 insertions(+), 45 deletions(-) diff --git a/lisp/simple.el b/lisp/simple.el index 0577454b414..668d037d2da 100644 --- a/lisp/simple.el +++ b/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." diff --git a/src/undo.c b/src/undo.c index f43ff0fb3e6..59dba6870c6 100644 --- a/src/undo.c +++ b/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))) - && NILP (Fgethash (Fnth (make_fixnum (3), entry), - Fnth (make_fixnum (2), entry), Qnil))) + && FIXNUMP (Fnth (make_fixnum (1), entry)) + && EQ (Fnth (make_fixnum (4), entry), + 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); } diff --git a/test/lisp/erc/erc-tests.el b/test/lisp/erc/erc-tests.el index f36b26f55fd..2543cc1195c 100644 --- a/test/lisp/erc/erc-tests.el +++ b/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 diff --git a/test/src/editfns-tests.el b/test/src/editfns-tests.el index 971aaf3f64f..da27fc24c3c 100644 --- a/test/src/editfns-tests.el +++ b/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 i buffer-undo-list) - (`(apply undo--adjust-weak-marker . ,_) t) - (`,_ nil))))) + (should (pcase-exhaustive (nth 1 buffer-undo-list) + (`(apply 0 1 6 undo--adjust-weak-markers + -6 (,_ . -1) 1 (,_ . 1)) + 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 i buffer-undo-list) - (`(apply undo--adjust-weak-marker . ,_) t) - (`,_ nil))))) + (should (pcase-exhaustive (nth 2 buffer-undo-list) + (`(apply 0 1 6 undo--adjust-weak-markers + 1 (,_ . 1) (,_ . 1) (,_ . 4)) + 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")