From: Stefan Monnier Date: Tue, 26 Dec 2017 03:51:23 +0000 (-0500) Subject: * lisp/register.el: Use cl-generic X-Git-Tag: emacs-27.0.90~5960 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=cd1d9e79f74f137511d49eb9b0ae7ba750ba6c3c;p=emacs.git * 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. --- diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 00278996792..5c16f64a6f8 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 23eefd08b88..0fdcd51dac6 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.