[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] master cd1d9e7: * lisp/register.el: Use cl-generic
From: |
Stefan Monnier |
Subject: |
[Emacs-diffs] master cd1d9e7: * lisp/register.el: Use cl-generic |
Date: |
Mon, 25 Dec 2017 22:51:32 -0500 (EST) |
branch: master
commit cd1d9e79f74f137511d49eb9b0ae7ba750ba6c3c
Author: Stefan Monnier <address@hidden>
Commit: Stefan Monnier <address@hidden>
* lisp/register.el: Use cl-generic
(registerv): Make it a "normal"struct.
(registerv-make): Declare obsolete.
(register-val-jump-to, register-val-describe, register-val-insert):
New generic functions.
(jump-to-register, describe-register-1, insert-register): Use them.
* lisp/emacs-lisp/cl-generic.el: Prefill a combination of struct+typeof.
(cl--generic-prefill-dispatchers): Allow a list of specializers.
---
lisp/emacs-lisp/cl-generic.el | 17 ++-
lisp/register.el | 260 +++++++++++++++++++++++-------------------
2 files changed, 151 insertions(+), 126 deletions(-)
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 0027899..5c16f64 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -808,22 +808,26 @@ methods.")
;; able to preload cl-generic without also preloading the byte-compiler,
;; So we use `eval-when-compile' so as not keep it available longer than
;; strictly needed.
-(defmacro cl--generic-prefill-dispatchers (arg-or-context specializer)
+(defmacro cl--generic-prefill-dispatchers (arg-or-context &rest specializers)
(unless (integerp arg-or-context)
(setq arg-or-context `(&context . ,arg-or-context)))
(unless (fboundp 'cl--generic-get-dispatcher)
(require 'cl-generic))
(let ((fun (cl--generic-get-dispatcher
- `(,arg-or-context ,@(cl-generic-generalizers specializer)
- ,cl--generic-t-generalizer))))
+ `(,arg-or-context
+ ,@(apply #'append
+ (mapcar #'cl-generic-generalizers specializers))
+ ,cl--generic-t-generalizer))))
;; Recompute dispatch at run-time, since the generalizers may be slightly
;; different (e.g. byte-compiled rather than interpreted).
;; FIXME: There is a risk that the run-time generalizer is not equivalent
;; to the compile-time one, in which case `fun' may not be correct
;; any more!
- `(let ((dispatch `(,',arg-or-context
- ,@(cl-generic-generalizers ',specializer)
- ,cl--generic-t-generalizer)))
+ `(let ((dispatch
+ `(,',arg-or-context
+ ,@(apply #'append
+ (mapcar #'cl-generic-generalizers ',specializers))
+ ,cl--generic-t-generalizer)))
;; (message "Prefilling for %S with \n%S" dispatch ',fun)
(puthash dispatch ',fun cl--generic-dispatchers)))))
@@ -1205,6 +1209,7 @@ See the full list and their hierarchy in
`cl--generic-typeof-types'."
(cl-call-next-method)))
(cl--generic-prefill-dispatchers 0 integer)
+(cl--generic-prefill-dispatchers 0 cl--generic-generalizer integer)
;;; Dispatch on major mode.
diff --git a/lisp/register.el b/lisp/register.el
index 23eefd0..0fdcd51 100644
--- a/lisp/register.el
+++ b/lisp/register.el
@@ -39,9 +39,7 @@
(registerv (:constructor nil)
(:constructor registerv--make (&optional data print-func
jump-func insert-func))
- (:copier nil)
- (:type vector)
- :named)
+ (:copier nil))
(data nil :read-only t)
(print-func nil :read-only t)
(jump-func nil :read-only t)
@@ -59,6 +57,7 @@ this sentence:
JUMP-FUNC if provided, controls how `jump-to-register' jumps to the register.
INSERT-FUNC if provided, controls how `insert-register' insert the register.
They both receive DATA as argument."
+ (declare (obsolete "Use your own type with methods on
register-val-(insert|describe|jump-to)" "27.1"))
(registerv--make data print-func jump-func insert-func))
(defvar register-alist nil
@@ -245,36 +244,44 @@ Interactively, reads the register using
`register-read-with-preview'."
(interactive (list (register-read-with-preview "Jump to register: ")
current-prefix-arg))
(let ((val (get-register register)))
- (cond
- ((registerv-p val)
- (cl-assert (registerv-jump-func val) nil
- "Don't know how to jump to register %s"
- (single-key-description register))
- (funcall (registerv-jump-func val) (registerv-data val)))
- ((and (consp val) (frame-configuration-p (car val)))
- (set-frame-configuration (car val) (not delete))
- (goto-char (cadr val)))
- ((and (consp val) (window-configuration-p (car val)))
- (set-window-configuration (car val))
- (goto-char (cadr val)))
- ((markerp val)
- (or (marker-buffer val)
- (user-error "That register's buffer no longer exists"))
- (switch-to-buffer (marker-buffer val))
- (unless (or (= (point) (marker-position val))
- (eq last-command 'jump-to-register))
- (push-mark))
- (goto-char val))
- ((and (consp val) (eq (car val) 'file))
- (find-file (cdr val)))
- ((and (consp val) (eq (car val) 'file-query))
- (or (find-buffer-visiting (nth 1 val))
- (y-or-n-p (format "Visit file %s again? " (nth 1 val)))
- (user-error "Register access aborted"))
- (find-file (nth 1 val))
- (goto-char (nth 2 val)))
- (t
- (user-error "Register doesn't contain a buffer position or
configuration")))))
+ (register-val-jump-to val delete)))
+
+(cl-defgeneric register-val-jump-to (_val _arg)
+ "Execute the \"jump\" operation of VAL.
+ARG is the value of the prefix argument or nil."
+ (user-error "Register doesn't contain a buffer position or configuration"))
+
+(cl-defmethod register-val-jump-to ((val registerv) _arg)
+ (cl-assert (registerv-jump-func val) nil
+ "Don't know how to jump to register value %S" val)
+ (funcall (registerv-jump-func val) (registerv-data val)))
+
+(cl-defmethod register-val-jump-to ((val marker) _arg)
+ (or (marker-buffer val)
+ (user-error "That register's buffer no longer exists"))
+ (switch-to-buffer (marker-buffer val))
+ (unless (or (= (point) (marker-position val))
+ (eq last-command 'jump-to-register))
+ (push-mark))
+ (goto-char val))
+
+(cl-defmethod register-val-jump-to ((val cons) delete)
+ (cond
+ ((frame-configuration-p (car val))
+ (set-frame-configuration (car val) (not delete))
+ (goto-char (cadr val)))
+ ((window-configuration-p (car val))
+ (set-window-configuration (car val))
+ (goto-char (cadr val)))
+ ((eq (car val) 'file)
+ (find-file (cdr val)))
+ ((eq (car val) 'file-query)
+ (or (find-buffer-visiting (nth 1 val))
+ (y-or-n-p (format "Visit file %s again? " (nth 1 val)))
+ (user-error "Register access aborted"))
+ (find-file (nth 1 val))
+ (goto-char (nth 2 val)))
+ (t (cl-call-next-method val delete))))
(defun register-swap-out ()
"Turn markers into file-query references when a buffer is killed."
@@ -356,79 +363,84 @@ Interactively, reads the register using
`register-read-with-preview'."
(princ (single-key-description register))
(princ " contains ")
(let ((val (get-register register)))
+ (register-val-describe val verbose)))
+
+(cl-defgeneric register-val-describe (val verbose)
+ "Print description of register value VAL to `standard-output'."
+ (princ "Garbage:\n")
+ (if verbose (prin1 val)))
+
+(cl-defmethod register-val-describe ((val registerv) _verbose)
+ (if (registerv-print-func val)
+ (funcall (registerv-print-func val) (registerv-data val))
+ (princ "[UNPRINTABLE CONTENTS].")))
+
+(cl-defmethod register-val-describe ((val number) _verbose)
+ (princ val))
+
+(cl-defmethod register-val-describe ((val marker) _verbose)
+ (let ((buf (marker-buffer val)))
+ (if (null buf)
+ (princ "a marker in no buffer")
+ (princ "a buffer position:\n buffer ")
+ (princ (buffer-name buf))
+ (princ ", position ")
+ (princ (marker-position val)))))
+
+(cl-defmethod register-val-describe ((val cons) verbose)
+ (cond
+ ((window-configuration-p (car val))
+ (princ "a window configuration."))
+
+ ((frame-configuration-p (car val))
+ (princ "a frame configuration."))
+
+ ((eq (car val) 'file)
+ (princ "the file ")
+ (prin1 (cdr val))
+ (princ "."))
+
+ ((eq (car val) 'file-query)
+ (princ "a file-query reference:\n file ")
+ (prin1 (car (cdr val)))
+ (princ ",\n position ")
+ (princ (car (cdr (cdr val))))
+ (princ "."))
+
+ (t
+ (if verbose
+ (progn
+ (princ "the rectangle:\n")
+ (while val
+ (princ " ")
+ (princ (car val))
+ (terpri)
+ (setq val (cdr val))))
+ (princ "a rectangle starting with ")
+ (princ (car val))))))
+
+(cl-defmethod register-val-describe ((val string) verbose)
+ (setq val (copy-sequence val))
+ (if (eq yank-excluded-properties t)
+ (set-text-properties 0 (length val) nil val)
+ (remove-list-of-text-properties 0 (length val)
+ yank-excluded-properties val))
+ (if verbose
+ (progn
+ (princ "the text:\n")
+ (princ val))
(cond
- ((registerv-p val)
- (if (registerv-print-func val)
- (funcall (registerv-print-func val) (registerv-data val))
- (princ "[UNPRINTABLE CONTENTS].")))
-
- ((numberp val)
- (princ val))
-
- ((markerp val)
- (let ((buf (marker-buffer val)))
- (if (null buf)
- (princ "a marker in no buffer")
- (princ "a buffer position:\n buffer ")
- (princ (buffer-name buf))
- (princ ", position ")
- (princ (marker-position val)))))
-
- ((and (consp val) (window-configuration-p (car val)))
- (princ "a window configuration."))
-
- ((and (consp val) (frame-configuration-p (car val)))
- (princ "a frame configuration."))
-
- ((and (consp val) (eq (car val) 'file))
- (princ "the file ")
- (prin1 (cdr val))
- (princ "."))
-
- ((and (consp val) (eq (car val) 'file-query))
- (princ "a file-query reference:\n file ")
- (prin1 (car (cdr val)))
- (princ ",\n position ")
- (princ (car (cdr (cdr val))))
- (princ "."))
-
- ((consp val)
- (if verbose
- (progn
- (princ "the rectangle:\n")
- (while val
- (princ " ")
- (princ (car val))
- (terpri)
- (setq val (cdr val))))
- (princ "a rectangle starting with ")
- (princ (car val))))
-
- ((stringp val)
- (setq val (copy-sequence val))
- (if (eq yank-excluded-properties t)
- (set-text-properties 0 (length val) nil val)
- (remove-list-of-text-properties 0 (length val)
- yank-excluded-properties val))
- (if verbose
- (progn
- (princ "the text:\n")
- (princ val))
- (cond
- ;; Extract first N characters starting with first non-whitespace.
- ((string-match (format "[^ \t\n].\\{,%d\\}"
- ;; Deduct 6 for the spaces inserted below.
- (min 20 (max 0 (- (window-width) 6))))
- val)
- (princ "text starting with\n ")
- (princ (match-string 0 val)))
- ((string-match "^[ \t\n]+$" val)
- (princ "whitespace"))
- (t
- (princ "the empty string")))))
+ ;; Extract first N characters starting with first non-whitespace.
+ ((string-match (format "[^ \t\n].\\{,%d\\}"
+ ;; Deduct 6 for the spaces inserted below.
+ (min 20 (max 0 (- (window-width) 6))))
+ val)
+ (princ "text starting with\n ")
+ (princ (match-string 0 val)))
+ ((string-match "^[ \t\n]+$" val)
+ (princ "whitespace"))
(t
- (princ "Garbage:\n")
- (if verbose (prin1 val))))))
+ (princ "the empty string")))))
(defun insert-register (register &optional arg)
"Insert contents of register REGISTER. (REGISTER is a character.)
@@ -444,24 +456,32 @@ Interactively, reads the register using
`register-read-with-preview'."
(not current-prefix-arg))))
(push-mark)
(let ((val (get-register register)))
- (cond
- ((registerv-p val)
- (cl-assert (registerv-insert-func val) nil
- "Don't know how to insert register %s"
- (single-key-description register))
- (funcall (registerv-insert-func val) (registerv-data val)))
- ((consp val)
- (insert-rectangle val))
- ((stringp val)
- (insert-for-yank val))
- ((numberp val)
- (princ val (current-buffer)))
- ((and (markerp val) (marker-position val))
- (princ (marker-position val) (current-buffer)))
- (t
- (user-error "Register does not contain text"))))
+ (register-val-insert val))
(if (not arg) (exchange-point-and-mark)))
+(cl-defgeneric register-val-insert (_val)
+ "Insert register value VAL."
+ (user-error "Register does not contain text"))
+
+(cl-defmethod register-val-insert ((val registerv))
+ (cl-assert (registerv-insert-func val) nil
+ "Don't know how to insert register value %S" val)
+ (funcall (registerv-insert-func val) (registerv-data val)))
+
+(cl-defmethod register-val-insert ((val cons))
+ (insert-rectangle val))
+
+(cl-defmethod register-val-insert ((val string))
+ (insert-for-yank val))
+
+(cl-defmethod register-val-insert ((val number))
+ (princ val (current-buffer)))
+
+(cl-defmethod register-val-insert ((val marker))
+ (if (marker-position val)
+ (princ (marker-position val) (current-buffer))
+ (cl-call-next-method val)))
+
(defun copy-to-register (register start end &optional delete-flag region)
"Copy region into register REGISTER.
With prefix arg, delete as well.
[Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Emacs-diffs] master cd1d9e7: * lisp/register.el: Use cl-generic,
Stefan Monnier <=