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,22 +808,26 @@ methods.") ...@@ -808,22 +808,26 @@ 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
,cl--generic-t-generalizer)))) ,@(apply #'append
(mapcar #'cl-generic-generalizers specializers))
,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
,cl--generic-t-generalizer))) ,@(apply #'append
(mapcar #'cl-generic-generalizers ',specializers))
,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,36 +244,44 @@ Interactively, reads the register using `register-read-with-preview'." ...@@ -245,36 +244,44 @@ 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-assert (registerv-jump-func val) nil (cl-defgeneric register-val-jump-to (_val _arg)
"Don't know how to jump to register %s" "Execute the \"jump\" operation of VAL.
(single-key-description register)) ARG is the value of the prefix argument or nil."
(funcall (registerv-jump-func val) (registerv-data val))) (user-error "Register doesn't contain a buffer position or configuration"))
((and (consp val) (frame-configuration-p (car val)))
(set-frame-configuration (car val) (not delete)) (cl-defmethod register-val-jump-to ((val registerv) _arg)
(goto-char (cadr val))) (cl-assert (registerv-jump-func val) nil
((and (consp val) (window-configuration-p (car val))) "Don't know how to jump to register value %S" val)
(set-window-configuration (car val)) (funcall (registerv-jump-func val) (registerv-data val)))
(goto-char (cadr val)))
((markerp val) (cl-defmethod register-val-jump-to ((val marker) _arg)
(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))
(unless (or (= (point) (marker-position val)) (unless (or (= (point) (marker-position val))
(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))
(find-file (cdr val))) (cl-defmethod register-val-jump-to ((val cons) delete)
((and (consp val) (eq (car val) 'file-query)) (cond
(or (find-buffer-visiting (nth 1 val)) ((frame-configuration-p (car val))
(y-or-n-p (format "Visit file %s again? " (nth 1 val))) (set-frame-configuration (car val) (not delete))
(user-error "Register access aborted")) (goto-char (cadr val)))
(find-file (nth 1 val)) ((window-configuration-p (car val))
(goto-char (nth 2 val))) (set-window-configuration (car val))
(t (goto-char (cadr val)))
(user-error "Register doesn't contain a buffer position or configuration"))))) ((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 () (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,79 +363,84 @@ Interactively, reads the register using `register-read-with-preview'." ...@@ -356,79 +363,84 @@ 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)))
(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 (cond
((registerv-p val) ;; Extract first N characters starting with first non-whitespace.
(if (registerv-print-func val) ((string-match (format "[^ \t\n].\\{,%d\\}"
(funcall (registerv-print-func val) (registerv-data val)) ;; Deduct 6 for the spaces inserted below.
(princ "[UNPRINTABLE CONTENTS]."))) (min 20 (max 0 (- (window-width) 6))))
val)
((numberp val) (princ "text starting with\n ")
(princ val)) (princ (match-string 0 val)))
((string-match "^[ \t\n]+$" val)
((markerp val) (princ "whitespace"))
(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")))))
(t (t
(princ "Garbage:\n") (princ "the empty string")))))
(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,24 +456,32 @@ Interactively, reads the register using `register-read-with-preview'." ...@@ -444,24 +456,32 @@ 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)
(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"))))
(if (not arg) (exchange-point-and-mark))) (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) (defun copy-to-register (register start end &optional delete-flag region)
"Copy region into register REGISTER. "Copy region into register REGISTER.
With prefix arg, delete as well. With prefix arg, delete as well.
......
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