geekinney/tp
1
0
Fork 0
Code Issues Pull Requests Actions 2 Packages Projects Releases Wiki Activity

chore: migrate conditional bindings for Emacs 31

Browse Source
This commit is contained in:
Kinneyzhang 2026-08-26 00:09:44 +08:00
parent 34b65b338f
commit edc51194b6
9 changed files with 51 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
examples/reactive-status.el
View File

@ -58,15 +58,15 @@ The returned state has keys:
(defun tp-example-reactive-status-dispose (state) (defun tp-example-reactive-status-dispose (state)
"Unmount reactive status STATE and dispose internal signals." "Unmount reactive status STATE and dispose internal signals."
(when-let ((surface (plist-get state :surface))) (when-let* ((surface (plist-get state :surface)))
(when (tp-surface-live-p surface) (when (tp-surface-live-p surface)
(tp-surface-unmount surface)) (tp-surface-unmount surface))
(setf (plist-get state :surface) nil)) (setf (plist-get state :surface) nil))
(when-let ((status (plist-get state :status))) (when-let* ((status (plist-get state :status)))
(when (tp-signal-live-p status) (when (tp-signal-live-p status)
(tp-signal-dispose status)) (tp-signal-dispose status))
(setf (plist-get state :status) nil)) (setf (plist-get state :status) nil))
(when-let ((noise (plist-get state :noise))) (when-let* ((noise (plist-get state :noise)))
(when (tp-signal-live-p noise) (when (tp-signal-live-p noise)
(tp-signal-dispose noise)) (tp-signal-dispose noise))
(setf (plist-get state :noise) nil))) (setf (plist-get state :noise) nil)))

2
tp-core.el
View File

@ -99,7 +99,7 @@ FORMAT-STRING and ARGS are passed to `format'."
(defun tp-debug-clear () (defun tp-debug-clear ()
"Clear the *tp-debug* buffer." "Clear the *tp-debug* buffer."
(interactive) (interactive)
(when-let ((buf (get-buffer "*tp-debug*"))) (when-let* ((buf (get-buffer "*tp-debug*")))
(with-current-buffer buf (with-current-buffer buf
(erase-buffer)))) (erase-buffer))))

16
tp-layer.el
View File

@ -117,22 +117,22 @@ Each entry has the form (NAME ARGLIST BODY-FORM).")
(defun tp-layer-parameterized-p (name) (defun tp-layer-parameterized-p (name)
"Return non-nil when layer recipe NAME accepts arguments." "Return non-nil when layer recipe NAME accepts arguments."
(when-let ((entry (tp--recipe-entry name tp-layer-alist))) (when-let* ((entry (tp--recipe-entry name tp-layer-alist)))
(and (car entry) t))) (and (car entry) t)))
(defun tp-layer-arglist (name) (defun tp-layer-arglist (name)
"Return a defensive copy of layer recipe NAME's argument list." "Return a defensive copy of layer recipe NAME's argument list."
(when-let ((entry (tp--recipe-entry name tp-layer-alist))) (when-let* ((entry (tp--recipe-entry name tp-layer-alist)))
(copy-sequence (car entry)))) (copy-sequence (car entry))))
(defun tp-group-parameterized-p (name) (defun tp-group-parameterized-p (name)
"Return non-nil when group recipe NAME accepts arguments." "Return non-nil when group recipe NAME accepts arguments."
(when-let ((entry (tp--recipe-entry name tp-layer-groups))) (when-let* ((entry (tp--recipe-entry name tp-layer-groups)))
(and (car entry) t))) (and (car entry) t)))
(defun tp--group-arglist (name) (defun tp--group-arglist (name)
"Return a defensive copy of group recipe NAME's argument list." "Return a defensive copy of group recipe NAME's argument list."
(when-let ((entry (tp--recipe-entry name tp-layer-groups))) (when-let* ((entry (tp--recipe-entry name tp-layer-groups)))
(copy-sequence (car entry)))) (copy-sequence (car entry))))
(defun tp--is-layer-name-p (symbol) (defun tp--is-layer-name-p (symbol)
@ -185,7 +185,7 @@ Each entry has the form (NAME ARGLIST BODY-FORM).")
(defun tp--layer-properties (name args) (defun tp--layer-properties (name args)
"Expand layer recipe NAME using ARGS." "Expand layer recipe NAME using ARGS."
(when-let ((entry (tp--recipe-entry name tp-layer-alist))) (when-let* ((entry (tp--recipe-entry name tp-layer-alist)))
(pcase-let ((`(,arglist ,body) entry)) (pcase-let ((`(,arglist ,body) entry))
(tp--check-layer-cycle name) (tp--check-layer-cycle name)
(let* ((tp--layer-expansion-stack (let* ((tp--layer-expansion-stack
@ -239,7 +239,7 @@ PROVENANCE is accepted for source compatibility and has no effect."
(defun tp--group-properties (name args) (defun tp--group-properties (name args)
"Return the ordered direct property groups produced by NAME with ARGS." "Return the ordered direct property groups produced by NAME with ARGS."
(when-let ((entry (tp--recipe-entry name tp-layer-groups))) (when-let* ((entry (tp--recipe-entry name tp-layer-groups)))
(pcase-let ((`(,arglist ,body) entry)) (pcase-let ((`(,arglist ,body) entry))
(tp--check-layer-cycle name) (tp--check-layer-cycle name)
(let* ((tp--layer-expansion-stack (let* ((tp--layer-expansion-stack
@ -324,7 +324,7 @@ Signal `tp-unresolved-layer' when a symbol does not name a recipe."
(defun tp--candidate-layer-parameterized-p (name layers) (defun tp--candidate-layer-parameterized-p (name layers)
"Return non-nil when NAME accepts arguments in candidate LAYERS." "Return non-nil when NAME accepts arguments in candidate LAYERS."
(when-let ((entry (tp--recipe-entry name layers))) (when-let* ((entry (tp--recipe-entry name layers)))
(and (car entry) t))) (and (car entry) t)))
(defun tp--candidate-layer-properties (name args layers groups) (defun tp--candidate-layer-properties (name args layers groups)
@ -526,7 +526,7 @@ Each BODY form evaluates to one layer name, recipe call, native property
(defun tp--describe-layer-data (name) (defun tp--describe-layer-data (name)
"Return declarative registry data for layer recipe NAME." "Return declarative registry data for layer recipe NAME."
(when-let ((entry (tp--recipe-entry name tp-layer-alist))) (when-let* ((entry (tp--recipe-entry name tp-layer-alist)))
(list :name name (list :name name
:kind 'direct-declaration-recipe :kind 'direct-declaration-recipe
:arglist (copy-sequence (car entry)) :arglist (copy-sequence (car entry))

2
tp-ops.el
View File

@ -310,7 +310,7 @@ target string/buffer itself."
;;;###autoload ;;;###autoload
(defun tp-member (position property &optional object) (defun tp-member (position property &optional object)
"Return (PROPERTY VALUE) when PROPERTY is present at POSITION in OBJECT." "Return (PROPERTY VALUE) when PROPERTY is present at POSITION in OBJECT."
(when-let ((member (plist-member (when-let* ((member (plist-member
(text-properties-at position object) property))) (text-properties-at position object) property)))
(list (car member) (cadr member)))) (list (car member) (cadr member))))

2
tp-query.el
View File

@ -67,7 +67,7 @@ MODE is recorded in the returned `tp-lookup-result'."
"Return the first non-nil alias value for PROPERTY at POSITION." "Return the first non-nil alias value for PROPERTY at POSITION."
(catch 'found (catch 'found
(dolist (alias (cdr (assq property char-property-alias-alist))) (dolist (alias (cdr (assq property char-property-alias-alist)))
(when-let ((value (get-text-property position alias object))) (when-let* ((value (get-text-property position alias object)))
(throw 'found (list alias value)))))) (throw 'found (list alias value))))))
(defun tp--lookup-source-cell (position property object) (defun tp--lookup-source-cell (position property object)

14
tp-reactive.el
View File

@ -190,7 +190,7 @@
(defun tp--unregister-binding (binding) (defun tp--unregister-binding (binding)
"Remove BINDING from owner and global registries." "Remove BINDING from owner and global registries."
(when-let ((table (tp--owner-binding-table (tp-binding-owner binding)))) (when-let* ((table (tp--owner-binding-table (tp-binding-owner binding))))
(remhash (tp-binding-key binding) table) (remhash (tp-binding-key binding) table)
(when (zerop (hash-table-count table)) (when (zerop (hash-table-count table))
(remhash (tp-binding-owner binding) tp--owner-bindings))) (remhash (tp-binding-owner binding) tp--owner-bindings)))
@ -347,7 +347,7 @@ dirty target has recomputed."
(when (eq (tp-binding-state binding) 'computing) (when (eq (tp-binding-state binding) 'computing)
(tp--signal-binding-cycle (tp--stack-cycle-path binding))) (tp--signal-binding-cycle (tp--stack-cycle-path binding)))
(unless computing-only (unless computing-only
(when-let ((path (tp--binding-dependency-path (when-let* ((path (tp--binding-dependency-path
binding tp--current-binding nil))) binding tp--current-binding nil)))
(tp--signal-binding-cycle (cons tp--current-binding path)))))) (tp--signal-binding-cycle (cons tp--current-binding path))))))
@ -567,7 +567,7 @@ and graph edges already produced by a compiler or pure projection pass."
(defun tp-binding-dispose-owner (owner) (defun tp-binding-dispose-owner (owner)
"Dispose every binding installed on OWNER and return the count." "Dispose every binding installed on OWNER and return the count."
(let ((bindings (when-let ((table (tp--owner-binding-table owner))) (let ((bindings (when-let* ((table (tp--owner-binding-table owner)))
(let (items) (let (items)
(maphash (lambda (_key binding) (push binding items)) table) (maphash (lambda (_key binding) (push binding items)) table)
(sort items (lambda (left right) (sort items (lambda (left right)
@ -581,7 +581,7 @@ and graph edges already produced by a compiler or pure projection pass."
(defun tp-binding-owner-bindings (owner) (defun tp-binding-owner-bindings (owner)
"Return OWNER's live bindings ordered by stable binding id." "Return OWNER's live bindings ordered by stable binding id."
(when-let ((table (tp--owner-binding-table owner))) (when-let* ((table (tp--owner-binding-table owner)))
(let (bindings) (let (bindings)
(maphash (lambda (_key binding) (push binding bindings)) table) (maphash (lambda (_key binding) (push binding bindings)) table)
(sort bindings (lambda (left right) (sort bindings (lambda (left right)
@ -998,7 +998,7 @@ the primary condition data."
"Forward SYMBOL's NEW-VALUE write into its exact signal adapter. "Forward SYMBOL's NEW-VALUE write into its exact signal adapter.
OPERATION and WHERE follow the standard variable watcher protocol." OPERATION and WHERE follow the standard variable watcher protocol."
(when (eq operation 'set) (when (eq operation 'set)
(when-let ((signal (gethash (tp--variable-signal-key (when-let* ((signal (gethash (tp--variable-signal-key
symbol (or where 'global)) symbol (or where 'global))
tp--variable-signals))) tp--variable-signals)))
(when (tp-signal-live-p signal) (when (tp-signal-live-p signal)
@ -1046,14 +1046,14 @@ OPERATION and WHERE follow the standard variable watcher protocol."
(delq signal (tp-binding-dependencies binding)) (delq signal (tp-binding-dependencies binding))
(tp-binding-dirty binding) t)) (tp-binding-dirty binding) t))
(clrhash (tp-signal-subscribers signal)) (clrhash (tp-signal-subscribers signal))
(when-let ((key (tp-signal-adapter-key signal))) (when-let* ((key (tp-signal-adapter-key signal)))
(remhash key tp--variable-signals) (remhash key tp--variable-signals)
(let ((symbol (car key))) (let ((symbol (car key)))
(unless (tp--symbol-has-variable-signal-p symbol) (unless (tp--symbol-has-variable-signal-p symbol)
(remove-variable-watcher symbol #'tp--variable-signal-watcher) (remove-variable-watcher symbol #'tp--variable-signal-watcher)
(setq tp--variable-signal-watched (setq tp--variable-signal-watched
(delq symbol tp--variable-signal-watched))))) (delq symbol tp--variable-signal-watched)))))
(when-let ((scope (and (bufferp (tp-signal-scope signal)) (when-let* ((scope (and (bufferp (tp-signal-scope signal))
(tp-signal-scope signal)))) (tp-signal-scope signal))))
(when (buffer-live-p scope) (when (buffer-live-p scope)
(with-current-buffer scope (with-current-buffer scope

4
tp-search.el
View File

@ -631,7 +631,7 @@ Returns the number of matches found (at most TIMES)."
(save-excursion (save-excursion
(goto-char search-start) (goto-char search-start)
(dotimes (i count) (dotimes (i count)
(when-let ((match (tp--property-search-forward (when-let* ((match (tp--property-search-forward
property value predicate not-current))) property value predicate not-current)))
(when (<= (prop-match-end match) search-end) (when (<= (prop-match-end match) search-end)
(when (= i (1- count)) (when (= i (1- count))
@ -812,7 +812,7 @@ Returns the number of matches found (at most TIMES)."
(dotimes (i count) (dotimes (i count)
;; `equal' matching by default, same as tp--forward-do's ;; `equal' matching by default, same as tp--forward-do's
;; predicate t. ;; predicate t.
(when-let ((match (tp--property-search-backward (when-let* ((match (tp--property-search-backward
property value predicate not-current))) property value predicate not-current)))
(when (>= (prop-match-beginning match) search-start) (when (>= (prop-match-beginning match) search-start)
(when (= i (1- count)) (when (= i (1- count))

6
tp-style.el
View File

@ -123,7 +123,7 @@ Return a rollback journal containing the previous buffer map and slot specs."
(defun tp-paint-slot-rollback-updates (journal) (defun tp-paint-slot-rollback-updates (journal)
"Restore paint slots from reverse-safe JOURNAL." "Restore paint slots from reverse-safe JOURNAL."
(when-let ((buffer (plist-get journal :buffer))) (when-let* ((buffer (plist-get journal :buffer)))
(when (buffer-live-p buffer) (when (buffer-live-p buffer)
(with-current-buffer buffer (with-current-buffer buffer
(setq-local face-remapping-alist (setq-local face-remapping-alist
@ -283,7 +283,7 @@ explicit nil remains present and is distinct from an absent declaration."
(defun tp-style-declarations (name) (defun tp-style-declarations (name)
"Return a defensive copy of named direct style NAME declarations." "Return a defensive copy of named direct style NAME declarations."
(when-let ((declarations (gethash name tp--named-styles))) (when-let* ((declarations (gethash name tp--named-styles)))
(tp--copy-property-value declarations))) (tp--copy-property-value declarations)))
(defun tp-undefine-style (name) (defun tp-undefine-style (name)
@ -304,7 +304,7 @@ explicit nil remains present and is distinct from an absent declaration."
(defun tp--project-policy-value (policy value) (defun tp--project-policy-value (policy value)
"Project VALUE through POLICY into direct Emacs text properties." "Project VALUE through POLICY into direct Emacs text properties."
(when-let ((projector (tp-property-policy-projector policy))) (when-let* ((projector (tp-property-policy-projector policy)))
(let ((projected (funcall projector value))) (let ((projected (funcall projector value)))
(unless (tp--declaration-list-p projected) (unless (tp--declaration-list-p projected)
(signal 'tp-invalid-declaration (signal 'tp-invalid-declaration

50
tp-surface.el
View File

@ -187,7 +187,7 @@ producer result to the active prepare transaction."
"Reject duplicate explicit keys among CHILDREN." "Reject duplicate explicit keys among CHILDREN."
(let ((seen (make-hash-table :test #'equal))) (let ((seen (make-hash-table :test #'equal)))
(dolist (child children) (dolist (child children)
(when-let ((key (tp-surface-plan-key child))) (when-let* ((key (tp-surface-plan-key child)))
(when (gethash key seen) (when (gethash key seen)
(signal 'tp-duplicate-object-key (list key))) (signal 'tp-duplicate-object-key (list key)))
(puthash key t seen))))) (puthash key t seen)))))
@ -1923,9 +1923,9 @@ MOUNT-SPECS and SURFACE provide ranges for PROPERTIES."
(dolist (property properties) (dolist (property properties)
(let ((result (tp--property-segment-result (let ((result (tp--property-segment-result
surface mount-specs start end property))) surface mount-specs start end property)))
(when-let ((entry (plist-get result :ledger))) (when-let* ((entry (plist-get result :ledger)))
(push entry ledger)) (push entry ledger))
(when-let ((operation (plist-get result :operation))) (when-let* ((operation (plist-get result :operation)))
(push operation operations))))) (push operation operations)))))
(cons (nreverse ledger) (nreverse operations)))) (cons (nreverse ledger) (nreverse operations))))
@ -2325,7 +2325,7 @@ caller reads the scalar summary from the surface instead."
(pcase-let ((`(,start . ,finish) (tp--surface-range surface))) (pcase-let ((`(,start . ,finish) (tp--surface-range surface)))
(push (list surface start finish) content)) (push (list surface start finish) content))
(dolist (mount (tp--surface-mounts surface)) (dolist (mount (tp--surface-mounts surface))
(when-let ((anchor (tp--surface-mount-anchor mount))) (when-let* ((anchor (tp--surface-mount-anchor mount)))
(unless (gethash anchor anchors) (unless (gethash anchor anchors)
(puthash anchor t anchors) (puthash anchor t anchors)
(push (list anchor (push (list anchor
@ -2388,7 +2388,7 @@ caller reads the scalar summary from the surface instead."
(defun tp--surface-scope-table (&optional create) (defun tp--surface-scope-table (&optional create)
"Return the transaction-local scope table, creating it when CREATE is non-nil." "Return the transaction-local scope table, creating it when CREATE is non-nil."
(when-let ((state (tp--transaction-extension (when-let* ((state (tp--transaction-extension
tp--surface-extension-key create))) tp--surface-extension-key create)))
(or (gethash 'scopes state) (or (gethash 'scopes state)
(when create (when create
@ -2398,13 +2398,13 @@ caller reads the scalar summary from the surface instead."
(defun tp--surface-scope-request (surface) (defun tp--surface-scope-request (surface)
"Return SURFACE's one-shot scope request in the active transaction." "Return SURFACE's one-shot scope request in the active transaction."
(when-let ((table (tp--surface-scope-table))) (when-let* ((table (tp--surface-scope-table)))
(gethash surface table))) (gethash surface table)))
(defun tp--clear-surface-scope-request (surface) (defun tp--clear-surface-scope-request (surface)
"Clear SURFACE's pending one-shot scope request when one exists." "Clear SURFACE's pending one-shot scope request when one exists."
(when tp--transaction-active (when tp--transaction-active
(when-let ((table (tp--surface-scope-table))) (when-let* ((table (tp--surface-scope-table)))
(remhash surface table)))) (remhash surface table))))
(defun tp--set-surface-scope-request (surface objects options) (defun tp--set-surface-scope-request (surface objects options)
@ -2785,7 +2785,7 @@ When SCOPED is non-nil, inspect only RANGES, including an empty set."
(fallback (tp--prepared-surface-scope-fallback prepared)) (fallback (tp--prepared-surface-scope-fallback prepared))
(patches (tp--prepared-surface-scope-patches prepared)) (patches (tp--prepared-surface-scope-patches prepared))
(touched (touched
(if-let ((batch (tp--prepared-surface-commit-batch prepared))) (if-let* ((batch (tp--prepared-surface-commit-batch prepared)))
(cl-loop for patch in (tp-commit-batch-patches batch) (cl-loop for patch in (tp-commit-batch-patches batch)
sum (length (plist-get patch :replacement))) sum (length (plist-get patch :replacement)))
(if (and scoped (not fallback)) (if (and scoped (not fallback))
@ -2894,7 +2894,7 @@ the generic property-operation ledger."
(defun tp--publish-buffer-content (prepared) (defun tp--publish-buffer-content (prepared)
"Publish PREPARED's text and properties, returning operation counts." "Publish PREPARED's text and properties, returning operation counts."
(cl-block publish (cl-block publish
(when-let ((batch (tp--prepared-surface-commit-batch prepared))) (when-let* ((batch (tp--prepared-surface-commit-batch prepared)))
(let ((surface (tp--prepared-surface-surface prepared))) (let ((surface (tp--prepared-surface-surface prepared)))
(tp--commit-batch-apply-patches surface batch) (tp--commit-batch-apply-patches surface batch)
(tp--publication-step 'text surface) (tp--publication-step 'text surface)
@ -3000,7 +3000,7 @@ the generic property-operation ledger."
(if (tp--prepared-surface-retained-mount-state-p prepared) (if (tp--prepared-surface-retained-mount-state-p prepared)
(tp--retain-candidate-mount-state prepared) (tp--retain-candidate-mount-state prepared)
(tp--create-candidate-mount-state prepared)) (tp--create-candidate-mount-state prepared))
(when-let ((batch (and (not (tp--prepared-surface-retained-mount-state-p (when-let* ((batch (and (not (tp--prepared-surface-retained-mount-state-p
prepared)) prepared))
(tp--prepared-surface-commit-batch prepared)))) (tp--prepared-surface-commit-batch prepared))))
(tp--commit-batch-validate-mounts (tp--commit-batch-validate-mounts
@ -3138,12 +3138,12 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback."
(pcase-let ((`(,buffer ,point-marker ,modified ,windows) state)) (pcase-let ((`(,buffer ,point-marker ,modified ,windows) state))
(when (buffer-live-p buffer) (when (buffer-live-p buffer)
(with-current-buffer buffer (with-current-buffer buffer
(when-let ((position (marker-position point-marker))) (when-let* ((position (marker-position point-marker)))
(goto-char (min (point-max) (max (point-min) position)))) (goto-char (min (point-max) (max (point-min) position))))
(set-buffer-modified-p modified)) (set-buffer-modified-p modified))
(dolist (entry windows) (dolist (entry windows)
(when (window-live-p (car entry)) (when (window-live-p (car entry))
(when-let ((position (marker-position (cdr entry)))) (when-let* ((position (marker-position (cdr entry))))
(set-window-start (car entry) position t))))) (set-window-start (car entry) position t)))))
(unless retain-markers (unless retain-markers
(tp--dispose-marker point-marker) (tp--dispose-marker point-marker)
@ -3436,14 +3436,14 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback."
(defun tp--surface-final-accept () (defun tp--surface-final-accept ()
"Accept the active surface transaction's prepared change group." "Accept the active surface transaction's prepared change group."
(when-let ((state (tp--transaction-extension tp--surface-extension-key))) (when-let* ((state (tp--transaction-extension tp--surface-extension-key)))
(when-let ((group (gethash 'change-group state))) (when-let* ((group (gethash 'change-group state)))
(accept-change-group group)))) (accept-change-group group))))
(defun tp--surface-precommit-transaction () (defun tp--surface-precommit-transaction ()
"Prepare every fallible surface transition before signal commit." "Prepare every fallible surface transition before signal commit."
(when-let ((state (tp--transaction-extension tp--surface-extension-key))) (when-let* ((state (tp--transaction-extension tp--surface-extension-key)))
(when-let ((table (gethash 'prepared state))) (when-let* ((table (gethash 'prepared state)))
(let ((all-prepared (tp--all-prepared-surfaces table)) (let ((all-prepared (tp--all-prepared-surfaces table))
(changed (gethash 'changed state))) (changed (gethash 'changed state)))
(when changed (when changed
@ -3462,7 +3462,7 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback."
(list (tp--surface-snapshot-mounts snapshot) (list (tp--surface-snapshot-mounts snapshot)
(tp--surface-mounts surface))) (tp--surface-mounts surface)))
(dolist (mount mounts) (dolist (mount mounts)
(when-let ((anchor (tp--surface-mount-anchor mount))) (when-let* ((anchor (tp--surface-mount-anchor mount)))
(push anchor anchors))))))) (push anchor anchors)))))))
(puthash 'anchor-undo (puthash 'anchor-undo
(tp--capture-anchor-ownership-undo (nreverse anchors)) (tp--capture-anchor-ownership-undo (nreverse anchors))
@ -3509,7 +3509,7 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback."
(defun tp--surface-rollback-transaction () (defun tp--surface-rollback-transaction ()
"Rollback buffers, side state, markers, and contexts for this transaction." "Rollback buffers, side state, markers, and contexts for this transaction."
(when-let ((state (tp--transaction-extension tp--surface-extension-key))) (when-let* ((state (tp--transaction-extension tp--surface-extension-key)))
(let (failures) (let (failures)
(cl-labels (cl-labels
((attempt (owner function) ((attempt (owner function)
@ -3550,9 +3550,9 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback."
(defun tp--surface-finalize-killed-rollback () (defun tp--surface-finalize-killed-rollback ()
"Dispose candidate contexts and reapply killed-buffer teardown." "Dispose candidate contexts and reapply killed-buffer teardown."
(when-let ((state (tp--transaction-extension tp--surface-extension-key))) (when-let* ((state (tp--transaction-extension tp--surface-extension-key)))
(let (failures) (let (failures)
(when-let ((table (gethash 'prepared state))) (when-let* ((table (gethash 'prepared state)))
(dolist (prepared (tp--all-prepared-surfaces table)) (dolist (prepared (tp--all-prepared-surfaces table))
(let ((surface (tp--prepared-surface-surface prepared))) (let ((surface (tp--prepared-surface-surface prepared)))
(condition-case failure (condition-case failure
@ -3572,7 +3572,7 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback."
"Return distinct range anchors referenced by MOUNTS." "Return distinct range anchors referenced by MOUNTS."
(let ((seen (make-hash-table :test #'eq)) anchors) (let ((seen (make-hash-table :test #'eq)) anchors)
(dolist (mount mounts) (dolist (mount mounts)
(when-let ((anchor (tp--surface-mount-anchor mount))) (when-let* ((anchor (tp--surface-mount-anchor mount)))
(unless (gethash anchor seen) (unless (gethash anchor seen)
(puthash anchor t seen) (puthash anchor t seen)
(push anchor anchors)))) (push anchor anchors))))
@ -3652,7 +3652,7 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback."
(defun tp--enqueue-surface-observers (surface) (defun tp--enqueue-surface-observers (surface)
"Schedule SURFACE observers outside the publishing transaction." "Schedule SURFACE observers outside the publishing transaction."
(when-let ((observers (tp--surface-observers surface))) (when-let* ((observers (tp--surface-observers surface)))
(let ((observers (copy-sequence observers)) (let ((observers (copy-sequence observers))
(report (tp-surface-report surface))) (report (tp-surface-report surface)))
(tp--enqueue-after-commit (tp--enqueue-after-commit
@ -3660,7 +3660,7 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback."
(defun tp--surface-commit-transaction () (defun tp--surface-commit-transaction ()
"Run contained postaccept cleanup for every transaction surface." "Run contained postaccept cleanup for every transaction surface."
(when-let ((state (tp--transaction-extension tp--surface-extension-key))) (when-let* ((state (tp--transaction-extension tp--surface-extension-key)))
(let ((changed (gethash 'changed state)) (let ((changed (gethash 'changed state))
(snapshots (gethash 'snapshots state))) (snapshots (gethash 'snapshots state)))
(cl-labels (cl-labels
@ -3675,7 +3675,7 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback."
(funcall function)) (funcall function))
((error quit) ((error quit)
(tp--record-cleanup-error surface owner failure)))))) (tp--record-cleanup-error surface owner failure))))))
(when-let ((prepared (car changed))) (when-let* ((prepared (car changed)))
(cleanup (cleanup
(tp--prepared-surface-surface prepared) 'view-markers (tp--prepared-surface-surface prepared) 'view-markers
(lambda () (tp--dispose-view-state (gethash 'views state))))) (lambda () (tp--dispose-view-state (gethash 'views state)))))
@ -3701,7 +3701,7 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback."
(lambda () (lambda ()
(tp--dispose-ledger (tp--dispose-ledger
(tp--surface-snapshot-ledger snapshot))))))) (tp--surface-snapshot-ledger snapshot)))))))
(when-let ((table (gethash 'prepared state))) (when-let* ((table (gethash 'prepared state)))
(dolist (prepared (tp--all-prepared-surfaces table)) (dolist (prepared (tp--all-prepared-surfaces table))
(let* ((surface (tp--prepared-surface-surface prepared)) (let* ((surface (tp--prepared-surface-surface prepared))
(context (tp--prepared-surface-context prepared))) (context (tp--prepared-surface-context prepared)))