mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-24 06:20:43 -08:00
Code Issues Projects Releases Wiki Activity

* lisp/register.el: Use cl-generic

Browse source 
(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.
This commit is contained in:
Stefan Monnier 2017-12-25 22:51:23 -05:00
parent cf13450db8
commit cd1d9e79f7
2 changed files with 151 additions and 126 deletions
Download patch file Download diff file Expand all files Collapse all files

13
lisp/emacs-lisp/cl-generic.el
View file

@ -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.

116
lisp/register.el
View file

@ -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,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.