Commit cd1d9e79 authored by Stefan Monnier's avatar Stefan Monnier

* 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.")
;; 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)
`(,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)
`(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.
......
......@@ -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,19 +244,19 @@ 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)
(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 %s"
(single-key-description register))
"Don't know how to jump to register value %S" val)
(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)
(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))
......@@ -265,16 +264,24 @@ Interactively, reads the register using `register-read-with-preview'."
(eq last-command 'jump-to-register))
(push-mark))
(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)))
((and (consp val) (eq (car val) 'file-query))
((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")))))
(t (cl-call-next-method val delete))))
(defun register-swap-out ()
"Turn markers into file-query references when a buffer is killed."
......@@ -356,16 +363,22 @@ Interactively, reads the register using `register-read-with-preview'."
(princ (single-key-description register))
(princ " contains ")
(let ((val (get-register register)))
(cond
((registerv-p val)
(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].")))
((numberp val)
(cl-defmethod register-val-describe ((val number) _verbose)
(princ val))
((markerp val)
(cl-defmethod register-val-describe ((val marker) _verbose)
(let ((buf (marker-buffer val)))
(if (null buf)
(princ "a marker in no buffer")
......@@ -374,25 +387,27 @@ Interactively, reads the register using `register-read-with-preview'."
(princ ", position ")
(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."))
((and (consp val) (frame-configuration-p (car val)))
((frame-configuration-p (car val))
(princ "a frame configuration."))
((and (consp val) (eq (car val) 'file))
((eq (car val) 'file)
(princ "the file ")
(prin1 (cdr val))
(princ "."))
((and (consp val) (eq (car val) 'file-query))
((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)
(t
(if verbose
(progn
(princ "the rectangle:\n")
......@@ -402,9 +417,9 @@ Interactively, reads the register using `register-read-with-preview'."
(terpri)
(setq val (cdr val))))
(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))
(if (eq yank-excluded-properties t)
(set-text-properties 0 (length val) nil val)
......@@ -426,9 +441,6 @@ Interactively, reads the register using `register-read-with-preview'."
(princ "whitespace"))
(t
(princ "the empty string")))))
(t
(princ "Garbage:\n")
(if verbose (prin1 val))))))
(defun insert-register (register &optional arg)
"Insert contents of register REGISTER. (REGISTER is a character.)
......@@ -444,23 +456,31 @@ Interactively, reads the register using `register-read-with-preview'."
(not current-prefix-arg))))
(push-mark)
(let ((val (get-register register)))
(cond
((registerv-p val)
(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 %s"
(single-key-description register))
"Don't know how to insert register value %S" val)
(funcall (registerv-insert-func val) (registerv-data val)))
((consp val)
(cl-defmethod register-val-insert ((val cons))
(insert-rectangle val))
((stringp val)
(cl-defmethod register-val-insert ((val string))
(insert-for-yank val))
((numberp val)
(cl-defmethod register-val-insert ((val number))
(princ val (current-buffer)))
((and (markerp val) (marker-position val))
(princ (marker-position val) (current-buffer)))
(t
(user-error "Register does not contain text"))))
(if (not arg) (exchange-point-and-mark)))
(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.
......
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