* lisp/emacs-lisp/cl-generic.el: Add (major-mode MODE) context

(cl--generic-derived-specializers): New function.
(cl--generic-derived-generalizer): New generalizer.
(cl-generic-generalizers): New specializer (derived-mode MODE).
(cl--generic-split-args): Apply the rewriter, if any.
(cl-generic-define-context-rewriter): New macro.
(major-mode): Use it to define a new context-rewriter, so we can write
`(major-mode MODE)' instead of `(major-mode (derived-mode MODE))'.

* lisp/frame.el (window-system): New context-rewriter so we can write
`(window-system VAL)' instead of (window-system (eql VAL)).
(cl--generic-split-args): Apply the rewriter, if any.
(frame-creation-function): Use the new syntax.

* lisp/term/x-win.el (window-system-initialization)
(handle-args-function, frame-creation-function)
(gui-backend-set-selection, gui-backend-selection-owner-p)
(gui-backend-selection-exists-p, gui-backend-get-selection):
* lisp/term/w32-win.el (window-system-initialization)
(handle-args-function, frame-creation-function)
(gui-backend-set-selection, gui-backend-get-selection)
(gui-backend-selection-owner-p, gui-backend-selection-exists-p):
* lisp/term/pc-win.el (gui-backend-get-selection)
(gui-backend-selection-exists-p, gui-backend-selection-owner-p)
(gui-backend-set-selection, window-system-initialization)
(frame-creation-function, handle-args-function):
* lisp/term/ns-win.el (window-system-initialization)
(handle-args-function, frame-creation-function)
(gui-backend-set-selection, gui-backend-selection-exists-p)
(gui-backend-get-selection):
* lisp/startup.el (handle-args-function):
* lisp/term/xterm.el (gui-backend-get-selection)
(gui-backend-set-selection): Use the new syntax.

1 files changed, 45 insertions, 0 deletions

diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 0d7ef5b2e61..aae517e8ea7 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -266,6 +266,15 @@ BODY, if present, is used as the body of a default method.
 This macro can only be used within the lexical scope of a cl-generic method."
   (error "cl-generic-current-method-specializers used outside of a method"))
 
+(defmacro cl-generic-define-context-rewriter (name args &rest body)
+  "Define a special kind of context named NAME.
+Whenever a context specializer of the form (NAME . ACTUALS) appears,
+the specializer used will be the one returned by BODY."
+  (declare (debug (&define name lambda-list def-body)) (indent defun))
+  `(eval-and-compile
+     (put ',name 'cl-generic--context-rewriter
+          (lambda ,args ,@body))))
+
 (eval-and-compile         ;Needed while compiling the cl-defmethod calls below!
   (defun cl--generic-fgrep (vars sexp)    ;Copied from pcase.el.
     "Check which of the symbols VARS appear in SEXP."
@@ -292,6 +301,11 @@ This macro can only be used within the lexical scope of a cl-generic method."
                 ((let 'context mandatory)
                  (unless (consp arg)
                    (error "Invalid &context arg: %S" arg))
+                 (let* ((name (car arg))
+                        (rewriter
+                         (and (symbolp name)
+                              (get name 'cl-generic--context-rewriter))))
+                   (if rewriter (setq arg (apply rewriter (cdr arg)))))
                  (push `((&context . ,(car arg)) . ,(cadr arg)) specializers)
                  nil)
                 (`(,name . ,type)
@@ -1106,6 +1120,37 @@ The value returned is a list of elements of the form
 
 (cl--generic-prefill-dispatchers 0 integer)
 
+;;; Dispatch on major mode.
+
+;; Two parts:
+;; - first define a specializer (derived-mode <mode>) to match symbols
+;;   representing major modes, while obeying the major mode hierarchy.
+;; - then define a context-rewriter so you can write
+;;   "&context (major-mode c-mode)" rather than
+;;   "&context (major-mode (derived-mode c-mode))".
+
+(defun cl--generic-derived-specializers (mode &rest _)
+  ;; FIXME: Handle (derived-mode <mode1> ... <modeN>)
+  (let ((specializers ()))
+    (while mode
+      (push `(derived-mode ,mode) specializers)
+      (setq mode (get mode 'derived-mode-parent)))
+    (nreverse specializers)))
+
+(cl-generic-define-generalizer cl--generic-derived-generalizer
+  90 (lambda (name) `(and (symbolp ,name) (functionp ,name) ,name))
+  #'cl--generic-derived-specializers)
+
+(cl-defmethod cl-generic-generalizers ((_specializer (head derived-mode)))
+  "Support for the `(derived-mode MODE)' specializers."
+  (list cl--generic-derived-generalizer))
+
+(cl-generic-define-context-rewriter major-mode (mode &rest modes)
+  `(major-mode ,(if (consp mode)
+                    ;;E.g. could be (eql ...)
+                    (progn (cl-assert (null modes)) mode)
+                  `(derived-mode ,mode . ,modes))))
+
 ;; Local variables:
 ;; generated-autoload-file: "cl-loaddefs.el"
 ;; End: