Commit cd1d9e79 authored by Stefan Monnier's avatar Stefan Monnier
Browse files

* 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.
parent cf13450d
...@@ -808,21 +808,25 @@ methods.") ...@@ -808,21 +808,25 @@ methods.")
;; able to preload cl-generic without also preloading the byte-compiler, ;; 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 ;; So we use `eval-when-compile' so as not keep it available longer than
;; strictly needed. ;; 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) (unless (integerp arg-or-context)
(setq arg-or-context `(&context . ,arg-or-context))) (setq arg-or-context `(&context . ,arg-or-context)))
(unless (fboundp 'cl--generic-get-dispatcher) (unless (fboundp 'cl--generic-get-dispatcher)
(require 'cl-generic)) (require 'cl-generic))
(let ((fun (cl--generic-get-dispatcher (let ((fun (cl--generic-get-dispatcher
`(,arg-or-context ,@(cl-generic-generalizers specializer) `(,arg-or-context
,@(apply #'append
(mapcar #'cl-generic-generalizers specializers))
,cl--generic-t-generalizer)))) ,cl--generic-t-generalizer))))
;; Recompute dispatch at run-time, since the generalizers may be slightly ;; Recompute dispatch at run-time, since the generalizers may be slightly
;; different (e.g. byte-compiled rather than interpreted). ;; different (e.g. byte-compiled rather than interpreted).
;; FIXME: There is a risk that the run-time generalizer is not equivalent ;; 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 ;; to the compile-time one, in which case `fun' may not be correct
;; any more! ;; any more!
`(let ((dispatch `(,',arg-or-context `(let ((dispatch
,@(cl-generic-generalizers ',specializer) `(,',arg-or-context
,@(apply #'append
(mapcar #'cl-generic-generalizers ',specializers))
,cl--generic-t-generalizer))) ,cl--generic-t-generalizer)))
;; (message "Prefilling for %S with \n%S" dispatch ',fun) ;; (message "Prefilling for %S with \n%S" dispatch ',fun)
(puthash dispatch ',fun cl--generic-dispatchers))))) (puthash dispatch ',fun cl--generic-dispatchers)))))
...@@ -1205,6 +1209,7 @@ See the full list and their hierarchy in `cl--generic-typeof-types'." ...@@ -1205,6 +1209,7 @@ See the full list and their hierarchy in `cl--generic-typeof-types'."
(cl-call-next-method))) (cl-call-next-method)))
(cl--generic-prefill-dispatchers 0 integer) (cl--generic-prefill-dispatchers 0 integer)
(cl--generic-prefill-dispatchers 0 cl--generic-generalizer integer)
;;; Dispatch on major mode. ;;; Dispatch on major mode.
......
...@@ -39,9 +39,7 @@ ...@@ -39,9 +39,7 @@
(registerv (:constructor nil) (registerv (:constructor nil)
(:constructor registerv--make (&optional data print-func (:constructor registerv--make (&optional data print-func
jump-func insert-func)) jump-func insert-func))
(:copier nil) (:copier nil))
(:type vector)
:named)
(data nil :read-only t) (data nil :read-only t)
(print-func nil :read-only t) (print-func nil :read-only t)
(jump-func nil :read-only t) (jump-func nil :read-only t)
...@@ -59,6 +57,7 @@ this sentence: ...@@ -59,6 +57,7 @@ this sentence:
JUMP-FUNC if provided, controls how `jump-to-register' jumps to the register. JUMP-FUNC if provided, controls how `jump-to-register' jumps to the register.
INSERT-FUNC if provided, controls how `insert-register' insert the register. INSERT-FUNC if provided, controls how `insert-register' insert the register.
They both receive DATA as argument." 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)) (registerv--make data print-func jump-func insert-func))
(defvar register-alist nil (defvar register-alist nil
...@@ -245,19 +244,19 @@ Interactively, reads the register using `register-read-with-preview'." ...@@ -245,19 +244,19 @@ Interactively, reads the register using `register-read-with-preview'."
(interactive (list (register-read-with-preview "Jump to register: ") (interactive (list (register-read-with-preview "Jump to register: ")
current-prefix-arg)) current-prefix-arg))
(let ((val (get-register register))) (let ((val (get-register register)))
(cond (register-val-jump-to val delete)))
((registerv-p val)
(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 (cl-assert (registerv-jump-func val) nil
"Don't know how to jump to register %s" "Don't know how to jump to register value %S" val)
(single-key-description register))
(funcall (registerv-jump-func val) (registerv-data val))) (funcall (registerv-jump-func val) (registerv-data val)))
((and (consp val) (frame-configuration-p (car val)))
(set-frame-configuration (car val) (not delete)) (cl-defmethod register-val-jump-to ((val marker) _arg)
(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) (or (marker-buffer val)
(user-error "That register's buffer no longer exists")) (user-error "That register's buffer no longer exists"))
(switch-to-buffer (marker-buffer val)) (switch-to-buffer (marker-buffer val))
...@@ -265,16 +264,24 @@ Interactively, reads the register using `register-read-with-preview'." ...@@ -265,16 +264,24 @@ Interactively, reads the register using `register-read-with-preview'."
(eq last-command 'jump-to-register)) (eq last-command 'jump-to-register))
(push-mark)) (push-mark))
(goto-char val)) (goto-char val))
((and (consp val) (eq (car val) 'file))
(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))) (find-file (cdr val)))
((and (consp val) (eq (car val) 'file-query)) ((eq (car val) 'file-query)
(or (find-buffer-visiting (nth 1 val)) (or (find-buffer-visiting (nth 1 val))
(y-or-n-p (format "Visit file %s again? " (nth 1 val))) (y-or-n-p (format "Visit file %s again? " (nth 1 val)))
(user-error "Register access aborted")) (user-error "Register access aborted"))
(find-file (nth 1 val)) (find-file (nth 1 val))
(goto-char (nth 2 val))) (goto-char (nth 2 val)))
(t (t (cl-call-next-method val delete))))
(user-error "Register doesn't contain a buffer position or configuration")))))
(defun register-swap-out () (defun register-swap-out ()
"Turn markers into file-query references when a buffer is killed." "Turn markers into file-query references when a buffer is killed."
...@@ -356,16 +363,22 @@ Interactively, reads the register using `register-read-with-preview'." ...@@ -356,16 +363,22 @@ Interactively, reads the register using `register-read-with-preview'."
(princ (single-key-description register)) (princ (single-key-description register))
(princ " contains ") (princ " contains ")
(let ((val (get-register register))) (let ((val (get-register register)))
(cond (register-val-describe val verbose)))
((registerv-p val)
(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) (if (registerv-print-func val)
(funcall (registerv-print-func val) (registerv-data val)) (funcall (registerv-print-func val) (registerv-data val))
(princ "[UNPRINTABLE CONTENTS]."))) (princ "[UNPRINTABLE CONTENTS].")))
((numberp val) (cl-defmethod register-val-describe ((val number) _verbose)
(princ val)) (princ val))
((markerp val) (cl-defmethod register-val-describe ((val marker) _verbose)
(let ((buf (marker-buffer val))) (let ((buf (marker-buffer val)))
(if (null buf) (if (null buf)
(princ "a marker in no buffer") (princ "a marker in no buffer")
...@@ -374,25 +387,27 @@ Interactively, reads the register using `register-read-with-preview'." ...@@ -374,25 +387,27 @@ Interactively, reads the register using `register-read-with-preview'."
(princ ", position ") (princ ", position ")
(princ (marker-position val))))) (princ (marker-position val)))))
((and (consp val) (window-configuration-p (car val))) (cl-defmethod register-val-describe ((val cons) verbose)
(cond
((window-configuration-p (car val))
(princ "a window configuration.")) (princ "a window configuration."))
((and (consp val) (frame-configuration-p (car val))) ((frame-configuration-p (car val))
(princ "a frame configuration.")) (princ "a frame configuration."))
((and (consp val) (eq (car val) 'file)) ((eq (car val) 'file)
(princ "the file ") (princ "the file ")
(prin1 (cdr val)) (prin1 (cdr val))
(princ ".")) (princ "."))
((and (consp val) (eq (car val) 'file-query)) ((eq (car val) 'file-query)
(princ "a file-query reference:\n file ") (princ "a file-query reference:\n file ")
(prin1 (car (cdr val))) (prin1 (car (cdr val)))
(princ ",\n position ") (princ ",\n position ")
(princ (car (cdr (cdr val)))) (princ (car (cdr (cdr val))))
(princ ".")) (princ "."))
((consp val) (t
(if verbose (if verbose
(progn (progn
(princ "the rectangle:\n") (princ "the rectangle:\n")
...@@ -402,9 +417,9 @@ Interactively, reads the register using `register-read-with-preview'." ...@@ -402,9 +417,9 @@ Interactively, reads the register using `register-read-with-preview'."
(terpri) (terpri)
(setq val (cdr val)))) (setq val (cdr val))))
(princ "a rectangle starting with ") (princ "a rectangle starting with ")
(princ (car val)))) (princ (car val))))))
((stringp val) (cl-defmethod register-val-describe ((val string) verbose)
(setq val (copy-sequence val)) (setq val (copy-sequence val))
(if (eq yank-excluded-properties t) (if (eq yank-excluded-properties t)
(set-text-properties 0 (length val) nil val) (set-text-properties 0 (length val) nil val)
...@@ -426,9 +441,6 @@ Interactively, reads the register using `register-read-with-preview'." ...@@ -426,9 +441,6 @@ Interactively, reads the register using `register-read-with-preview'."
(princ "whitespace")) (princ "whitespace"))
(t (t
(princ "the empty string"))))) (princ "the empty string")))))
(t
(princ "Garbage:\n")
(if verbose (prin1 val))))))
(defun insert-register (register &optional arg) (defun insert-register (register &optional arg)
"Insert contents of register REGISTER. (REGISTER is a character.) "Insert contents of register REGISTER. (REGISTER is a character.)
...@@ -444,23 +456,31 @@ Interactively, reads the register using `register-read-with-preview'." ...@@ -444,23 +456,31 @@ Interactively, reads the register using `register-read-with-preview'."
(not current-prefix-arg)))) (not current-prefix-arg))))
(push-mark) (push-mark)
(let ((val (get-register register))) (let ((val (get-register register)))
(cond (register-val-insert val))
((registerv-p 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 (cl-assert (registerv-insert-func val) nil
"Don't know how to insert register %s" "Don't know how to insert register value %S" val)
(single-key-description register))
(funcall (registerv-insert-func val) (registerv-data val))) (funcall (registerv-insert-func val) (registerv-data val)))
((consp val)
(cl-defmethod register-val-insert ((val cons))
(insert-rectangle val)) (insert-rectangle val))
((stringp val)
(cl-defmethod register-val-insert ((val string))
(insert-for-yank val)) (insert-for-yank val))
((numberp val)
(cl-defmethod register-val-insert ((val number))
(princ val (current-buffer))) (princ val (current-buffer)))
((and (markerp val) (marker-position val))
(princ (marker-position val) (current-buffer))) (cl-defmethod register-val-insert ((val marker))
(t (if (marker-position val)
(user-error "Register does not contain text")))) (princ (marker-position val) (current-buffer))
(if (not arg) (exchange-point-and-mark))) (cl-call-next-method val)))
(defun copy-to-register (register start end &optional delete-flag region) (defun copy-to-register (register start end &optional delete-flag region)
"Copy region into register REGISTER. "Copy region into register REGISTER.
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment