bug#66394: 29.1; Make register-read-with-preview more useful

[Eshel Yaron via "Bug reports for GNU Emacs, the Swiss army knife of text editors" <bug-gnu-emacs@gnu.org>]

[-- Attachment #1: Type: text/plain, Size: 1437 bytes --]

Hi Eli,

Eli Zaretskii <eliz@gnu.org> writes:

>> From: Eshel Yaron <me@eshelyaron.com>
>> Cc: michael_heerdegen@web.de,  Eli Zaretskii <eliz@gnu.org>,
>>   stefankangas@gmail.com,  monnier@iro.umontreal.ca,  66394@debbugs.gnu.org
>> Date: Sun, 03 Dec 2023 19:29:19 +0100
>> 
>> > otherwise it is easy to revert completely my commits (it is the
>> > development branch of emacs after all).
>> 
>> Seeing as you are not willing to make this change backward compatible, I
>> think that would make sense.  I don't have commit rights to emacs.git,
>> so I can't do that myself, though.
>
> Thierry also said:
>
>> > So it'd be great to have the previous behavior available in Emacs 30.
>> 
>> Sorry but I wont write this, it is not complicated to write but needs
>> works and attention and I spent enough time on this.
>
> So maybe a better way forward is for someone, perhaps you Eshel, to
> add whatever is needed to provide optionally the previous behavior?
>
> Would you like to work on that?

Sure.  I'm attaching two patches, the first reverts to the previous
implementation, and the second adds optional (on by default)
confirmation and highlighting in the *Register Preview* buffer when you
are about to overwrite the contents of a register.

The idea is to provide the nice of enhancements from Thierry's patch via
more minimal changes, without switching to a minibuffer based approach,
and without breaking any existing behavior.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Revert-recent-register-preview-changes.patch --]
[-- Type: text/x-patch, Size: 19163 bytes --]

From 220c600dd8b57de5ff44974ecfddd6f36dc9c3cd Mon Sep 17 00:00:00 2001
From: Eshel Yaron <me@eshelyaron.com>
Date: Sun, 3 Dec 2023 20:02:42 +0100
Subject: [PATCH 1/2] Revert recent register preview changes

This reverts commits cd6e66f955d20d31686a617ed8a5cd043585c71f,
408126b6d56a0cc36f621348212e16d0715fd671,
0fa70dad21d3475d3a5dae54a09d8a9e60b668ae,
3df81fb5dc5809cab7843e5358c17d0039b55eb1,
589e6ae1fb983bfba42f20906773555037246e45.
---
 doc/emacs/regs.texi           |   5 +-
 etc/NEWS                      |   5 -
 lisp/emacs-lisp/cl-generic.el |   1 -
 lisp/register.el              | 298 +++++-----------------------------
 test/lisp/register-tests.el   |  43 +++++
 5 files changed, 84 insertions(+), 268 deletions(-)
 create mode 100644 test/lisp/register-tests.el

diff --git a/doc/emacs/regs.texi b/doc/emacs/regs.texi
index 5e5b7ae2b16..e52f68dd18e 100644
--- a/doc/emacs/regs.texi
+++ b/doc/emacs/regs.texi
@@ -16,8 +16,9 @@ Registers
 we will denote by @var{r}; @var{r} can be a letter (such as @samp{a})
 or a number (such as @samp{1}); case matters, so register @samp{a} is
 not the same as register @samp{A}.  You can also set a register in
-non-alphanumeric characters, for instance @samp{C-d} by using for
-example @key{C-q} @samp{C-d}.
+non-alphanumeric characters, for instance @samp{*} or @samp{C-d}.
+Note, it's not possible to set a register in @samp{C-g} or @samp{ESC},
+because these keys are reserved for quitting (@pxref{Quitting}).
 
 @findex view-register
   A register can store a position, a piece of text, a rectangle, a
diff --git a/etc/NEWS b/etc/NEWS
index 29f4e5c0b66..af8e1049483 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1154,11 +1154,6 @@ showcases all their customization options.
 \f
 * Incompatible Lisp Changes in Emacs 30.1
 
----
-** 'register-preview-delay' is no longer used.
-Register preview is no more delayed.  If you want to disable it use
-'register-use-preview' instead with a boolean value.
-
 +++
 ** 'M-TAB' now invokes 'completion-at-point' also in Text mode.
 Text mode no longer binds 'M-TAB' to 'ispell-complete-word', and
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 0ef0d1e192a..56eb83e6f75 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -1379,7 +1379,6 @@ cl-generic-generalizers
 (cl--generic-prefill-dispatchers 0 integer)
 (cl--generic-prefill-dispatchers 1 integer)
 (cl--generic-prefill-dispatchers 0 cl--generic-generalizer integer)
-(cl--generic-prefill-dispatchers 0 (eql 'x) integer)
 
 ;;; Dispatch on major mode.
 
diff --git a/lisp/register.el b/lisp/register.el
index 46ec38821e5..ca6de450993 100644
--- a/lisp/register.el
+++ b/lisp/register.el
@@ -35,8 +35,6 @@
 
 ;; FIXME: Clean up namespace usage!
 
-(declare-function frameset-register-p "frameset")
-
 (cl-defstruct
   (registerv (:constructor nil)
 	     (:constructor registerv--make (&optional data print-func
@@ -100,15 +98,6 @@ register-preview-delay
   :version "24.4"
   :type '(choice number (const :tag "No preview unless requested" nil))
   :group 'register)
-(make-obsolete-variable 'register-preview-delay "No longer used." "30.1")
-
-(defcustom register-preview-default-keys (mapcar #'string (number-sequence ?a ?z))
-  "Default keys for setting a new register."
-  :type '(repeat string))
-
-(defcustom register-use-preview t
-  "Always show register preview when non nil."
-  :type 'boolean)
 
 (defun get-register (register)
   "Return contents of Emacs register named REGISTER, or nil if none."
@@ -131,8 +120,7 @@ register-describe-oneline
 (defun register-preview-default (r)
   "Function that is the default value of the variable `register-preview-function'."
   (format "%s: %s\n"
-	  (propertize (string (car r))
-                      'display (single-key-description (car r)))
+	  (single-key-description (car r))
 	  (register-describe-oneline (car r))))
 
 (defvar register-preview-function #'register-preview-default
@@ -140,263 +128,53 @@ register-preview-function
 Called with one argument, a cons (NAME . CONTENTS) as found in `register-alist'.
 The function should return a string, the description of the argument.")
 
-(cl-defstruct register-preview-info
-  "Store data for a specific register command.
-TYPES are the types of register supported.
-MSG is the minibuffer message to send when a register is selected.
-ACT is the type of action the command is doing on register.
-SMATCH accept a boolean value to say if command accept non matching register."
-  types msg act smatch)
-
-(cl-defgeneric register-command-info (command)
-  "Returns a `register-preview-info' object storing data for COMMAND."
-  (ignore command))
-(cl-defmethod register-command-info ((_command (eql insert-register)))
-  (make-register-preview-info
-   :types '(string number)
-   :msg "Insert register `%s'"
-   :act 'insert
-   :smatch t))
-(cl-defmethod register-command-info ((_command (eql jump-to-register)))
-  (make-register-preview-info
-   :types  '(window frame marker kmacro
-             file buffer file-query)
-   :msg "Jump to register `%s'"
-   :act 'jump
-   :smatch t))
-(cl-defmethod register-command-info ((_command (eql view-register)))
-  (make-register-preview-info
-   :types '(all)
-   :msg "View register `%s'"
-   :act 'view
-   :smatch t))
-(cl-defmethod register-command-info ((_command (eql append-to-register)))
-  (make-register-preview-info
-   :types '(string number)
-   :msg "Append to register `%s'"
-   :act 'modify
-   :smatch t))
-(cl-defmethod register-command-info ((_command (eql prepend-to-register)))
-  (make-register-preview-info
-   :types '(string number)
-   :msg "Prepend to register `%s'"
-   :act 'modify
-   :smatch t))
-(cl-defmethod register-command-info ((_command (eql increment-register)))
-  (make-register-preview-info
-   :types '(string number)
-   :msg "Increment register `%s'"
-   :act 'modify
-   :smatch t))
-
-(defun register-preview-forward-line (arg)
-  "Move to next or previous line in register preview buffer.
-If ARG is positive goto next line, if negative to previous.
-Do nothing when defining or executing kmacros."
-  ;; Ensure user enter manually key in minibuffer when recording a macro.
-  (unless (or defining-kbd-macro executing-kbd-macro
-              (not (get-buffer-window "*Register Preview*" 'visible)))
-    (let ((fn (if (> arg 0) #'eobp #'bobp))
-          (posfn (if (> arg 0)
-                     #'point-min
-                     (lambda () (1- (point-max)))))
-          str)
-      (with-current-buffer "*Register Preview*"
-        (let ((ovs (overlays-in (point-min) (point-max)))
-              pos)
-          (goto-char (if ovs
-                         (overlay-start (car ovs))
-                         (point-min)))
-          (setq pos (point))
-          (and ovs (forward-line arg))
-          (when (and (funcall fn)
-                     (or (> arg 0) (eql pos (point))))
-            (goto-char (funcall posfn)))
-          (setq str (buffer-substring-no-properties
-                     (pos-bol) (1+ (pos-bol))))
-          (remove-overlays)
-          (with-selected-window (minibuffer-window)
-            (delete-minibuffer-contents)
-            (insert str)))))))
-
-(defun register-preview-next ()
-  "Goto next line in register preview buffer."
-  (interactive)
-  (register-preview-forward-line 1))
-
-(defun register-preview-previous ()
-  "Goto previous line in register preview buffer."
-  (interactive)
-  (register-preview-forward-line -1))
-
-(defun register-type (register)
-  "Return REGISTER type.
-Current register types actually returned are one of:
-- string
-- number
-- marker
-- buffer
-- file
-- file-query
-- window
-- frame
-- kmacro
-
-One can add new types to a specific command by defining a new `cl-defmethod'
-matching this command. Predicate for type in new `cl-defmethod' should
-satisfy `cl-typep' otherwise the new type should be defined with
-`cl-deftype'."
-  ;; Call register--type against the register value.
-  (register--type (if (consp (cdr register))
-                     (cadr register)
-                   (cdr register))))
-
-(cl-defgeneric register--type (regval)
-  "Returns type of register value REGVAL."
-  (ignore regval))
-
-(cl-defmethod register--type ((_regval string)) 'string)
-(cl-defmethod register--type ((_regval number)) 'number)
-(cl-defmethod register--type ((_regval marker)) 'marker)
-(cl-defmethod register--type ((_regval (eql 'buffer))) 'buffer)
-(cl-defmethod register--type ((_regval (eql 'file))) 'file)
-(cl-defmethod register--type ((_regval (eql 'file-query))) 'file-query)
-(cl-defmethod register--type ((_regval window-configuration)) 'window)
-(cl-deftype frame-register () '(satisfies frameset-register-p))
-(cl-defmethod register--type :extra "frame-register" (_regval) 'frame)
-(cl-deftype kmacro-register () '(satisfies kmacro-register-p))
-(cl-defmethod register--type :extra "kmacro-register" (_regval) 'kmacro)
-
-(defun register-of-type-alist (types)
-  "Filter `register-alist' according to TYPES."
-  (if (memq 'all types)
-      register-alist
-    (cl-loop for register in register-alist
-             when (memq (register-type register) types)
-             collect register)))
-
-(defun register-preview (buffer &optional show-empty types)
+(defun register-preview (buffer &optional show-empty)
   "Pop up a window showing the registers preview in BUFFER.
 If SHOW-EMPTY is non-nil, show the window even if no registers.
-Argument TYPES (a list) specify the types of register to show, when nil show all
-registers, see `register-type' for suitable types.
 Format of each entry is controlled by the variable `register-preview-function'."
-  (let ((registers (register-of-type-alist (or types '(all)))))
-    (when (or show-empty (consp registers))
-      (with-current-buffer-window
-        buffer
-        (cons 'display-buffer-below-selected
-	      '((window-height . fit-window-to-buffer)
-	        (preserve-size . (nil . t))))
-        nil
-        (with-current-buffer standard-output
-          (setq cursor-in-non-selected-windows nil)
-          (mapc (lambda (elem)
-                  (when (get-register (car elem))
-                    (insert (funcall register-preview-function elem))))
-                registers))))))
-
-(cl-defgeneric register-preview-get-defaults (action)
-  "Returns default registers according to ACTION."
-  (ignore action))
-(cl-defmethod register-preview-get-defaults ((_action (eql set)))
-  (cl-loop for s in register-preview-default-keys
-           unless (assoc (string-to-char s) register-alist)
-           collect s))
+  (when (or show-empty (consp register-alist))
+    (with-current-buffer-window
+     buffer
+     (cons 'display-buffer-below-selected
+	   '((window-height . fit-window-to-buffer)
+	     (preserve-size . (nil . t))))
+     nil
+     (with-current-buffer standard-output
+       (setq cursor-in-non-selected-windows nil)
+       (mapc (lambda (elem)
+               (when (get-register (car elem))
+                 (insert (funcall register-preview-function elem))))
+             register-alist)))))
 
 (defun register-read-with-preview (prompt)
   "Read and return a register name, possibly showing existing registers.
-Prompt with the string PROMPT.
+Prompt with the string PROMPT.  If `register-alist' and
+`register-preview-delay' are both non-nil, display a window
+listing existing registers after `register-preview-delay' seconds.
 If `help-char' (or a member of `help-event-list') is pressed,
 display such a window regardless."
   (let* ((buffer "*Register Preview*")
-         (pat "")
-         (map (let ((m (make-sparse-keymap)))
-                (set-keymap-parent m minibuffer-local-map)
-                m))
-         (data (register-command-info this-command))
-         types msg result timer act win strs smatch)
-    (if data
-        (setq types  (register-preview-info-types data)
-              msg    (register-preview-info-msg   data)
-              act    (register-preview-info-act   data)
-              smatch (register-preview-info-smatch data))
-      (setq types '(all)
-            msg   "Overwrite register `%s'"
-            act   'set))
-    (setq strs (mapcar (lambda (x)
-                         (string (car x)))
-                       (register-of-type-alist types)))
-    (when (and (memq act '(insert jump view)) (null strs))
-      (error "No register suitable for `%s'" act))
-    (dolist (k (cons help-char help-event-list))
-      (define-key map
-          (vector k) (lambda ()
-                       (interactive)
-                       (unless (get-buffer-window buffer)
-                         (with-selected-window (minibuffer-selected-window)
-                           (register-preview buffer 'show-empty types))))))
-    (define-key map (kbd "<down>") 'register-preview-next)
-    (define-key map (kbd "<up>")   'register-preview-previous)
-    (define-key map (kbd "C-n")    'register-preview-next)
-    (define-key map (kbd "C-p")    'register-preview-previous)
-    (unless (or executing-kbd-macro (null register-use-preview))
-      (register-preview buffer nil types))
+	 (timer (when (numberp register-preview-delay)
+		  (run-with-timer register-preview-delay nil
+				  (lambda ()
+				    (unless (get-buffer-window buffer)
+				      (register-preview buffer))))))
+	 (help-chars (cl-loop for c in (cons help-char help-event-list)
+			      when (not (get-register c))
+			      collect c)))
     (unwind-protect
-         (progn
-           (minibuffer-with-setup-hook
-               (lambda ()
-                 (setq timer
-                       (run-with-idle-timer
-                        0.01 'repeat
-                        (lambda ()
-                          (with-selected-window (minibuffer-window)
-                            (let ((input (minibuffer-contents)))
-                              (when (> (length input) 1)
-                                (let ((new (substring input 1))
-                                      (old (substring input 0 1)))
-                                  (setq input (if (or (null smatch)
-                                                      (member new strs))
-                                                  new old))
-                                  (delete-minibuffer-contents)
-                                  (insert input)))
-                              (when (and smatch (not (string= input ""))
-                                         (not (member input strs)))
-                                (setq input "")
-                                (delete-minibuffer-contents)
-                                (minibuffer-message "Not matching"))
-                              (when (not (string= input pat))
-                                (setq pat input))))
-                          (if (setq win (get-buffer-window buffer))
-                              (with-selected-window win
-                                (let ((ov (make-overlay (point-min) (point-min))))
-                                  (goto-char (point-min))
-                                  (remove-overlays)
-                                  (unless (string= pat "")
-                                    (if (re-search-forward (concat "^" pat) nil t)
-                                        (progn (move-overlay
-                                                ov
-                                                (match-beginning 0) (pos-eol))
-                                               (overlay-put ov 'face 'match)
-                                               (when msg
-                                                 (with-selected-window (minibuffer-window)
-                                                   (minibuffer-message msg pat))))
-                                      (with-selected-window (minibuffer-window)
-                                        (minibuffer-message
-                                         "Register `%s' is empty" pat))))))
-                            (unless (string= pat "")
-                              (if (member pat strs)
-                                  (with-selected-window (minibuffer-window)
-                                    (minibuffer-message msg pat))
-                                (with-selected-window (minibuffer-window)
-                                  (minibuffer-message
-                                   "Register `%s' is empty" pat)))))))))
-             (setq result (read-from-minibuffer
-                           prompt nil map nil nil (register-preview-get-defaults act))))
-           (cl-assert (and result (not (string= result "")))
-                      nil "No register specified")
-           (string-to-char result))
-      (when timer (cancel-timer timer))
+	(progn
+	  (while (memq (read-key (propertize prompt 'face 'minibuffer-prompt))
+		       help-chars)
+	    (unless (get-buffer-window buffer)
+	      (register-preview buffer 'show-empty)))
+          (when (or (eq ?\C-g last-input-event)
+                    (eq 'escape last-input-event)
+                    (eq ?\C-\[ last-input-event))
+            (keyboard-quit))
+	  (if (characterp last-input-event) last-input-event
+	    (error "Non-character input-event")))
+      (and (timerp timer) (cancel-timer timer))
       (let ((w (get-buffer-window buffer)))
         (and (window-live-p w) (delete-window w)))
       (and (get-buffer buffer) (kill-buffer buffer)))))
diff --git a/test/lisp/register-tests.el b/test/lisp/register-tests.el
new file mode 100644
index 00000000000..6283d1c31e0
--- /dev/null
+++ b/test/lisp/register-tests.el
@@ -0,0 +1,43 @@
+;;; register-tests.el --- tests for register.el  -*- lexical-binding: t-*-
+
+;; Copyright (C) 2017-2023 Free Software Foundation, Inc.
+
+;; Author: Tino Calancha <tino.calancha@gmail.com>
+;; Keywords:
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+\f
+;;; Code:
+(require 'ert)
+(require 'cl-lib)
+
+(ert-deftest register-test-bug27634 ()
+  "Test for https://debbugs.gnu.org/27634 ."
+  (dolist (event (list ?\C-g 'escape ?\C-\[))
+    (cl-letf (((symbol-function 'read-key) #'ignore)
+              (last-input-event event)
+              (register-alist nil))
+      (should (equal 'quit
+                     (condition-case err
+                         (call-interactively 'point-to-register)
+                       (quit (car err)))))
+      (should-not register-alist))))
+
+(provide 'register-tests)
+;;; register-tests.el ends here
-- 
2.42.0


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #3: 0002-Optionally-ask-for-confirmation-before-overwriting-r.patch --]
[-- Type: text/x-patch, Size: 13524 bytes --]

From d1538aadc4f3d0da6a8c550248f8d348edb96116 Mon Sep 17 00:00:00 2001
From: Eshel Yaron <me@eshelyaron.com>
Date: Sun, 3 Dec 2023 20:44:16 +0100
Subject: [PATCH 2/2] Optionally ask for confirmation before overwriting
 registers

Commands can now call 'register-read-with-preview' with optional
argument CONFIRM to ask the user for confirmation if they choose a
register that is already in use, subject to new user option
'register-confirm-overwrite'.  Commands that write to registers are
adapted to make use of this new argument.  When asking for
confirmation, Emacs also highlights the selected register in
the *Register Preview* buffer.

* lisp/register.el (register-confirm-overwrite): New user option.
(register-preview): New optional argument HIGHLIGHT.
(register-read-with-preview): Use them.  New optional arg CONFIRM.
(point-to-register,window-configuration-to-register)
(frame-configuration-to-register,number-to-register)
(copy-to-register,copy-rectangle-to-register)
* lisp/textmodes/picture.el (picture-clear-rectangle-to-register)
* lisp/calc/calc-yank.el (calc-copy-to-register)
* lisp/cedet/semantic/senator.el (senator-copy-tag-to-register)
* lisp/frameset.el (frameset-to-register)
* lisp/kmacro.el (kmacro-to-register)
* lisp/play/gametree.el (gametree-layout-to-register): Use new arg.
* doc/lispref/text.texi (Registers): Update.
* etc/NEWS: Announce.
---
 doc/lispref/text.texi          |  8 +++--
 etc/NEWS                       |  6 ++++
 lisp/calc/calc-yank.el         |  2 +-
 lisp/cedet/semantic/senator.el |  2 +-
 lisp/frameset.el               |  2 +-
 lisp/kmacro.el                 |  2 +-
 lisp/play/gametree.el          |  2 +-
 lisp/register.el               | 62 ++++++++++++++++++++++++----------
 lisp/textmodes/picture.el      |  2 +-
 9 files changed, 61 insertions(+), 27 deletions(-)

diff --git a/doc/lispref/text.texi b/doc/lispref/text.texi
index 5d05ef18d4f..9f5b846b92d 100644
--- a/doc/lispref/text.texi
+++ b/doc/lispref/text.texi
@@ -4710,7 +4710,7 @@ Registers
 changed in the future.
 @end deffn
 
-@defun register-read-with-preview prompt
+@defun register-read-with-preview prompt &optional confirm
 @cindex register preview
 This function reads and returns a register name, prompting with
 @var{prompt} and possibly showing a preview of the existing registers
@@ -4718,8 +4718,10 @@ Registers
 the delay specified by the user option @code{register-preview-delay},
 if its value and @code{register-alist} are both non-@code{nil}.  The
 preview is also shown if the user requests help (e.g., by typing the
-help character).  We recommend that all interactive commands which
-read register names use this function.
+help character).  If optional argument @var{confirm} is
+non-@code{nil}, this function asks for confirmation before returning a
+register that is already in use.  We recommend that all interactive
+commands which read register names use this function.
 @end defun
 
 @node Transposition
diff --git a/etc/NEWS b/etc/NEWS
index af8e1049483..0617c8dc218 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1085,6 +1085,12 @@ macros with many lines, such as from 'kmacro-edit-lossage'.
 
 ** Miscellaneous
 
++++
+*** New user option 'register-confirm-overwrite'.
+Emacs now defaults to asking for confirmation before overwriting
+registers with existing contents.  To disable such confirmation,
+customize this option to nil.
+
 ---
 *** Webjump now assumes URIs are HTTPS instead of HTTP.
 For links in 'webjump-sites' without an explicit URI scheme, it was
diff --git a/lisp/calc/calc-yank.el b/lisp/calc/calc-yank.el
index a2a91dc8fb8..ed1a8e1c046 100644
--- a/lisp/calc/calc-yank.el
+++ b/lisp/calc/calc-yank.el
@@ -281,7 +281,7 @@ calc-copy-to-register
 With prefix arg, delete as well.
 
 Interactively, reads the register using `register-read-with-preview'."
-  (interactive (list (register-read-with-preview "Copy to register: ")
+  (interactive (list (register-read-with-preview "Copy to register: " t)
 		     (region-beginning) (region-end)
 		     current-prefix-arg))
   (if (eq major-mode 'calc-mode)
diff --git a/lisp/cedet/semantic/senator.el b/lisp/cedet/semantic/senator.el
index ca4334eaff5..2c1fc4fda3b 100644
--- a/lisp/cedet/semantic/senator.el
+++ b/lisp/cedet/semantic/senator.el
@@ -736,7 +736,7 @@ senator-copy-tag-to-register
 kill ring.
 
 Interactively, reads the register using `register-read-with-preview'."
-  (interactive (list (register-read-with-preview "Tag to register: ")
+  (interactive (list (register-read-with-preview "Tag to register: " t)
                      current-prefix-arg))
   (semantic-fetch-tags)
   (let ((ft (semantic-obtain-foreign-tag)))
diff --git a/lisp/frameset.el b/lisp/frameset.el
index 224746bbfe3..63ff4668541 100644
--- a/lisp/frameset.el
+++ b/lisp/frameset.el
@@ -1451,7 +1451,7 @@ frameset-to-register
 Argument is a character, naming the register.
 
 Interactively, reads the register using `register-read-with-preview'."
-  (interactive (list (register-read-with-preview "Frameset to register: ")))
+  (interactive (list (register-read-with-preview "Frameset to register: " t)))
   (set-register register
 		(frameset-make-register
                  (frameset-save nil
diff --git a/lisp/kmacro.el b/lisp/kmacro.el
index 588b2d14943..a7aa2c88508 100644
--- a/lisp/kmacro.el
+++ b/lisp/kmacro.el
@@ -967,7 +967,7 @@ kmacro-to-register
   (interactive
    (progn
      (or last-kbd-macro (error "No keyboard macro defined"))
-     (list (register-read-with-preview "Save to register: "))))
+     (list (register-read-with-preview "Save to register: " t))))
   (set-register r (kmacro-ring-head)))
 
 
diff --git a/lisp/play/gametree.el b/lisp/play/gametree.el
index 971d8ea70ca..e46770af2da 100644
--- a/lisp/play/gametree.el
+++ b/lisp/play/gametree.el
@@ -523,7 +523,7 @@ gametree-layout-to-register
 Argument is a character, naming the register.
 
 Interactively, reads the register using `register-read-with-preview'."
-  (interactive (list (register-read-with-preview "Layout to register: ")))
+  (interactive (list (register-read-with-preview "Layout to register: " t)))
   (save-excursion
     (goto-char (point-min))
     (set-register register
diff --git a/lisp/register.el b/lisp/register.el
index ca6de450993..4e400fbff2c 100644
--- a/lisp/register.el
+++ b/lisp/register.el
@@ -99,6 +99,12 @@ register-preview-delay
   :type '(choice number (const :tag "No preview unless requested" nil))
   :group 'register)
 
+(defcustom register-confirm-overwrite t
+  "Whether to ask for confirmation before overwriting register contents."
+  :version "30.1"
+  :type 'boolean
+  :group 'register)
+
 (defun get-register (register)
   "Return contents of Emacs register named REGISTER, or nil if none."
   (alist-get register register-alist))
@@ -128,10 +134,12 @@ register-preview-function
 Called with one argument, a cons (NAME . CONTENTS) as found in `register-alist'.
 The function should return a string, the description of the argument.")
 
-(defun register-preview (buffer &optional show-empty)
+(defun register-preview (buffer &optional show-empty highlight)
   "Pop up a window showing the registers preview in BUFFER.
 If SHOW-EMPTY is non-nil, show the window even if no registers.
-Format of each entry is controlled by the variable `register-preview-function'."
+Optional argument HIGHLIGHT says to highlight the description of
+a register with that name.  Format of each entry is controlled by
+the variable `register-preview-function'."
   (when (or show-empty (consp register-alist))
     (with-current-buffer-window
      buffer
@@ -140,19 +148,26 @@ register-preview
 	     (preserve-size . (nil . t))))
      nil
      (with-current-buffer standard-output
+       (delete-region (point-min) (point-max))
        (setq cursor-in-non-selected-windows nil)
        (mapc (lambda (elem)
-               (when (get-register (car elem))
-                 (insert (funcall register-preview-function elem))))
+               (when-let ((name (car elem))
+                          (reg (get-register name))
+                          (desc (funcall register-preview-function elem)))
+                 (when (equal highlight name)
+                   (add-face-text-property 0 (length desc) 'match nil desc))
+                 (insert desc)))
              register-alist)))))
 
-(defun register-read-with-preview (prompt)
+(defun register-read-with-preview (prompt &optional confirm)
   "Read and return a register name, possibly showing existing registers.
-Prompt with the string PROMPT.  If `register-alist' and
+Prompt with the string PROMPT.  Optional argument CONFIRM says to
+ask for confirmation if the register is already in use and
+`register-confirm-overwrite' is non-nil.  If `register-alist' and
 `register-preview-delay' are both non-nil, display a window
-listing existing registers after `register-preview-delay' seconds.
-If `help-char' (or a member of `help-event-list') is pressed,
-display such a window regardless."
+listing existing registers after `register-preview-delay'
+seconds.  If `help-char' (or a member of `help-event-list') is
+pressed, display such a window regardless."
   (let* ((buffer "*Register Preview*")
 	 (timer (when (numberp register-preview-delay)
 		  (run-with-timer register-preview-delay nil
@@ -168,10 +183,20 @@ register-read-with-preview
 		       help-chars)
 	    (unless (get-buffer-window buffer)
 	      (register-preview buffer 'show-empty)))
-          (when (or (eq ?\C-g last-input-event)
-                    (eq 'escape last-input-event)
-                    (eq ?\C-\[ last-input-event))
+          (cond
+           ((or (eq ?\C-g last-input-event)
+                (eq 'escape last-input-event)
+                (eq ?\C-\[ last-input-event))
             (keyboard-quit))
+           ((and (get-register last-input-event)
+                 confirm register-confirm-overwrite
+                 (not (progn
+                        (register-preview buffer nil last-input-event)
+                        (y-or-n-p (substitute-quotes
+                                   (format "Overwrite register `%s'?"
+                                           (single-key-description
+                                            last-input-event))))))
+                 (user-error "Register already in use"))))
 	  (if (characterp last-input-event) last-input-event
 	    (error "Non-character input-event")))
       (and (timerp timer) (cancel-timer timer))
@@ -189,7 +214,8 @@ point-to-register
   (interactive (list (register-read-with-preview
                       (if current-prefix-arg
                           "Frame configuration to register: "
-                        "Point to register: "))
+                        "Point to register: ")
+                      t)
                      current-prefix-arg))
   ;; Turn the marker into a file-ref if the buffer is killed.
   (add-hook 'kill-buffer-hook 'register-swap-out nil t)
@@ -204,7 +230,7 @@ window-configuration-to-register
 
 Interactively, prompt for REGISTER using `register-read-with-preview'."
   (interactive (list (register-read-with-preview
-		      "Window configuration to register: ")
+		      "Window configuration to register: " t)
 		     current-prefix-arg))
   ;; current-window-configuration does not include the value
   ;; of point in the current buffer, so record that separately.
@@ -222,7 +248,7 @@ frame-configuration-to-register
 
 Interactively, prompt for REGISTER using `register-read-with-preview'."
   (interactive (list (register-read-with-preview
-		      "Frame configuration to register: ")
+		      "Frame configuration to register: " t)
 		     current-prefix-arg))
   ;; current-frame-configuration does not include the value
   ;; of point in the current buffer, so record that separately.
@@ -316,7 +342,7 @@ number-to-register
 
 Interactively, prompt for REGISTER using `register-read-with-preview'."
   (interactive (list current-prefix-arg
-		     (register-read-with-preview "Number to register: ")))
+		     (register-read-with-preview "Number to register: " t)))
   (set-register register
 		(if number
 		    (prefix-numeric-value number)
@@ -527,7 +553,7 @@ copy-to-register
 Interactively, prompt for REGISTER using `register-read-with-preview'
 and use mark and point as START and END; REGION is always non-nil in
 this case."
-  (interactive (list (register-read-with-preview "Copy to register: ")
+  (interactive (list (register-read-with-preview "Copy to register: " t)
 		     (region-beginning)
 		     (region-end)
 		     current-prefix-arg
@@ -605,7 +631,7 @@ copy-rectangle-to-register
 Interactively, prompt for REGISTER using `register-read-with-preview',
 and use mark and point as START and END."
   (interactive (list (register-read-with-preview
-		      "Copy rectangle to register: ")
+		      "Copy rectangle to register: " t)
 		     (region-beginning)
 		     (region-end)
 		     current-prefix-arg))
diff --git a/lisp/textmodes/picture.el b/lisp/textmodes/picture.el
index f98c3963b6f..efa59e0682f 100644
--- a/lisp/textmodes/picture.el
+++ b/lisp/textmodes/picture.el
@@ -503,7 +503,7 @@ picture-clear-rectangle-to-register
 
 Interactively, reads the register using `register-read-with-preview'."
   (interactive (list (region-beginning) (region-end)
-		     (register-read-with-preview "Rectangle to register: ")
+		     (register-read-with-preview "Rectangle to register: " t)
 		     current-prefix-arg))
   (set-register register (picture-snarf-rectangle start end killp)))
 
-- 
2.42.0