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

diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 0d7ef5b2e61af707a321ff5e5444c51519e16187..aae517e8ea713da767860e15f903577a6eb4db3d 100644 (file)
--- 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:

diff --git a/lisp/frame.el b/lisp/frame.el
index b9e63d541076412d251ce41f090a60f53ac0de25..f5508517dc6ee9e1b3254af3d55e5c625baeb1ff 100644 (file)
--- a/lisp/frame.el
+++ b/lisp/frame.el
@@ -33,8 +33,12 @@ The window system startup file should add its frame creation
 function to this method, which should take an alist of parameters
 as its argument.")
 
-(cl-defmethod frame-creation-function (params
-                                       &context (window-system (eql nil)))
+(cl-generic-define-context-rewriter window-system (value)
+  ;; If `value' is a `consp', it's probably an old-style specializer,
+  ;; so just use it, and anyway `eql' isn't very useful on cons cells.
+  `(window-system ,(if (consp value) value `(eql ,value))))
+
+(cl-defmethod frame-creation-function (params &context (window-system nil))
   ;; It's tempting to get rid of tty-create-frame-with-faces and turn it into
   ;; this method (i.e. move this method to faces.el), but faces.el is loaded
   ;; much earlier from loadup.el (before cl-generic and even before

diff --git a/lisp/startup.el b/lisp/startup.el
index 3385567317013fa8ea186fa6af1c7e766f62d16b..13463107d2e0a86274b32e53c4854f394b6ae203 100644 (file)
--- a/lisp/startup.el
+++ b/lisp/startup.el
@@ -720,7 +720,7 @@ Window system startup files should add their own function to this
 method, which should parse the command line arguments.  Those
 pertaining to the window system should be processed and removed
 from the returned command line.")
-(cl-defmethod handle-args-function (args &context (window-system (eql nil)))
+(cl-defmethod handle-args-function (args &context (window-system nil))
   (tty-handle-args args))
 
 (cl-defgeneric window-system-initialization (&optional _display)

diff --git a/lisp/term/ns-win.el b/lisp/term/ns-win.el
index 373f81238a273384b8441877de2b949a5fa47cef..0b3e3bd9d9c051875d84eefb9476856e151c3347 100644 (file)
--- a/lisp/term/ns-win.el
+++ b/lisp/term/ns-win.el
@@ -848,7 +848,7 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.")
 
 ;; Do the actual Nextstep Windows setup here; the above code just
 ;; defines functions and variables that we use now.
-(cl-defmethod window-system-initialization (&context (window-system (eql ns))
+(cl-defmethod window-system-initialization (&context (window-system ns)
                                             &optional _display)
   "Initialize Emacs for Nextstep (Cocoa / GNUstep) windowing."
   (cl-assert (not ns-initialized))
@@ -922,10 +922,10 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.")
 
 ;; Any display name is OK.
 (add-to-list 'display-format-alist '(".*" . ns))
-(cl-defmethod handle-args-function (args &context (window-system (eql ns)))
+(cl-defmethod handle-args-function (args &context (window-system ns))
   (x-handle-args args))
 
-(cl-defmethod frame-creation-function (params &context (window-system (eql ns)))
+(cl-defmethod frame-creation-function (params &context (window-system ns))
   (x-create-frame-with-faces params))
 
 (declare-function ns-own-selection-internal "nsselect.m" (selection value))
@@ -935,20 +935,20 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.")
 (declare-function ns-get-selection "nsselect.m" (selection-symbol target-type))
 
 (cl-defmethod gui-backend-set-selection (selection value
-                                         &context (window-system (eql ns)))
+                                         &context (window-system ns))
   (if value (ns-own-selection-internal selection value)
     (ns-disown-selection-internal selection)))
 
 (cl-defmethod gui-backend-selection-owner-p (selection
-                                             &context (window-system (eql ns)))
+                                             &context (window-system ns))
   (ns-selection-owner-p selection))
 
 (cl-defmethod gui-backend-selection-exists-p (selection
-                                              &context (window-system (eql ns)))
+                                              &context (window-system ns))
   (ns-selection-exists-p selection))
 
 (cl-defmethod gui-backend-get-selection (selection-symbol target-type
-                                         &context (window-system (eql ns)))
+                                         &context (window-system ns))
   (ns-get-selection selection-symbol target-type))
 
 (provide 'ns-win)

diff --git a/lisp/term/pc-win.el b/lisp/term/pc-win.el
index e8aaa1a6829b253c809f2af84ec70ea97e2815fa..d2afaba9b966d8b69576f35ad8828a9e3e82b441 100644 (file)
--- a/lisp/term/pc-win.el
+++ b/lisp/term/pc-win.el
@@ -221,7 +221,7 @@ the operating system.")
 
 ;; gui-get-selection is used in select.el
 (cl-defmethod gui-backend-get-selection (_selection-symbol _target-type
-                                         &context (window-system (eql pc)))
+                                         &context (window-system pc))
   "Return the value of the current selection.
 Consult the selection.  Treat empty strings as if they were unset."
   ;; Don't die if x-get-selection signals an error.
@@ -231,11 +231,11 @@ Consult the selection.  Treat empty strings as if they were unset."
 (declare-function w16-selection-exists-p "w16select.c")
 ;; gui-selection-owner-p is used in simple.el.
 (cl-defmethod gui-backend-selection-exists-p (selection
-                                              &context (window-system (eql pc)))
+                                              &context (window-system pc))
   (w16-selection-exists-p selection))
 
 (cl-defmethod gui-backend-selection-owner-p (selection
-                                             &context (window-system (eql pc)))
+                                             &context (window-system pc))
   (w16-selection-owner-p selection))
 
 (defun w16-selection-owner-p (_selection)
@@ -258,7 +258,7 @@ Consult the selection.  Treat empty strings as if they were unset."
 (declare-function w16-set-clipboard-data "w16select.c"
                  (string &optional ignored))
 (cl-defmethod gui-backend-set-selection (selection value
-                                         &context (window-system (eql pc)))
+                                         &context (window-system pc))
   (if (not value)
       (if (w16-selection-owner-p selection)
           t)
@@ -333,7 +333,7 @@ Errors out because it is not supposed to be called, ever."
         (window-system)))
 
 ;; window-system-initialization is called by startup.el:command-line.
-(cl-defmethod window-system-initialization (&context (window-system (eql pc))
+(cl-defmethod window-system-initialization (&context (window-system pc)
                                             &optional _display)
   "Initialization function for the `pc' \"window system\"."
   (or (eq (window-system) 'pc)
@@ -377,12 +377,12 @@ Errors out because it is not supposed to be called, ever."
   (run-hooks 'terminal-init-msdos-hook))
 
 ;; frame-creation-function is called by frame.el:make-frame.
-(cl-defmethod frame-creation-function (params &context (window-system (eql pc)))
+(cl-defmethod frame-creation-function (params &context (window-system pc))
   (msdos-create-frame-with-faces params))
 
 ;; We don't need anything beyond tty-handle-args for handling
 ;; command-line argument; see startup.el.
-(cl-defmethod handle-args-function (args &context (window-system (eql pc)))
+(cl-defmethod handle-args-function (args &context (window-system pc))
   (tty-handle-args args))
 
 ;; ---------------------------------------------------------------------------

diff --git a/lisp/term/w32-win.el b/lisp/term/w32-win.el
index 8bbc3ddf10da52621ee1cfd5db9879c5c795be55..181fd494eab12b46a490ffabd9f15715ff5ba950 100644 (file)
--- a/lisp/term/w32-win.el
+++ b/lisp/term/w32-win.el
@@ -290,7 +290,7 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.")
 (declare-function x-parse-geometry "frame.c" (string))
 (defvar x-command-line-resources)
 
-(cl-defmethod window-system-initialization (&context (window-system (eql w32))
+(cl-defmethod window-system-initialization (&context (window-system w32)
                                             &optional _display)
   "Initialize Emacs for W32 GUI frames."
   (cl-assert (not w32-initialized))
@@ -377,10 +377,10 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.")
   (setq w32-initialized t))
 
 (add-to-list 'display-format-alist '("\\`w32\\'" . w32))
-(cl-defmethod handle-args-function (args &context (window-system (eql w32)))
+(cl-defmethod handle-args-function (args &context (window-system w32))
   (x-handle-args args))
 
-(cl-defmethod frame-creation-function (params &context (window-system (eql w32)))
+(cl-defmethod frame-creation-function (params &context (window-system w32))
   (x-create-frame-with-faces params))
 
 ;;;; Selections
@@ -408,19 +408,19 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.")
        (get 'x-selections (or selection 'PRIMARY))))
 
 (cl-defmethod gui-backend-set-selection (type value
-                                         &context (window-system (eql w32)))
+                                         &context (window-system w32))
   (w32--set-selection type value))
 
 (cl-defmethod gui-backend-get-selection (type data-type
-                                         &context (window-system (eql w32)))
+                                         &context (window-system w32))
   (w32--get-selection type data-type))
 
 (cl-defmethod gui-backend-selection-owner-p (selection
-                                             &context (window-system (eql w32)))
+                                             &context (window-system w32))
   (w32--selection-owner-p selection))
 
 (cl-defmethod gui-backend-selection-exists-p (selection
-                                              &context (window-system (eql w32)))
+                                              &context (window-system w32))
   (w32-selection-exists-p selection))
 
 (when (eq system-type 'windows-nt)
@@ -428,19 +428,19 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.")
   ;; We could move those cl-defmethods outside of the `when' and use
   ;; "&context (system-type (eql windows-nt))" instead!
   (cl-defmethod gui-backend-set-selection (type value
-                                           &context (window-system (eql nil)))
+                                           &context (window-system nil))
     (w32--set-selection type value))
 
   (cl-defmethod gui-backend-get-selection (type data-type
-                                           &context (window-system (eql nil)))
+                                           &context (window-system nil))
     (w32--get-selection type data-type))
 
   (cl-defmethod gui-backend-selection-owner-p (selection
-                                               &context (window-system (eql nil)))
+                                               &context (window-system nil))
     (w32--selection-owner-p selection))
 
   (cl-defmethod gui-selection-exists-p (selection
-                                        &context (window-system (eql nil)))
+                                        &context (window-system nil))
     (w32-selection-exists-p selection)))
 
 ;; The "Windows" keys on newer keyboards bring up the Start menu

diff --git a/lisp/term/x-win.el b/lisp/term/x-win.el
index 5eb6f115f8b7550bb162c925c56c589a9a194619..690401e1970d9090109c933824319c3e343cfeda 100644 (file)
--- a/lisp/term/x-win.el
+++ b/lisp/term/x-win.el
@@ -1197,7 +1197,7 @@ This returns an error if any Emacs frames are X frames."
 (defvar x-display-name)
 (defvar x-command-line-resources)
 
-(cl-defmethod window-system-initialization (&context (window-system (eql x))
+(cl-defmethod window-system-initialization (&context (window-system x)
                                             &optional display)
   "Initialize Emacs for X frames and open the first connection to an X server."
   (cl-assert (not x-initialized))
@@ -1327,27 +1327,27 @@ This returns an error if any Emacs frames are X frames."
                  (selection-symbol target-type &optional time-stamp terminal))
 
 (add-to-list 'display-format-alist '("\\`[^:]*:[0-9]+\\(\\.[0-9]+\\)?\\'" . x))
-(cl-defmethod handle-args-function (args &context (window-system (eql x)))
+(cl-defmethod handle-args-function (args &context (window-system x))
   (x-handle-args args))
 
-(cl-defmethod frame-creation-function (params &context (window-system (eql x)))
+(cl-defmethod frame-creation-function (params &context (window-system x))
   (x-create-frame-with-faces params))
 
 (cl-defmethod gui-backend-set-selection (selection value
-                                         &context (window-system (eql x)))
+                                         &context (window-system x))
   (if value (x-own-selection-internal selection value)
     (x-disown-selection-internal selection)))
 
 (cl-defmethod gui-backend-selection-owner-p (selection
-                                             &context (window-system (eql x)))
+                                             &context (window-system x))
   (x-selection-owner-p selection))
 
 (cl-defmethod gui-backend-selection-exists-p (selection
-                                              &context (window-system (eql x)))
+                                              &context (window-system x))
   (x-selection-exists-p selection))
 
 (cl-defmethod gui-backend-get-selection (selection-symbol target-type
-                                         &context (window-system (eql x))
+                                         &context (window-system x)
                                          &optional time-stamp terminal)
   (x-get-selection-internal selection-symbol target-type time-stamp terminal))
 

diff --git a/lisp/term/xterm.el b/lisp/term/xterm.el
index 300e494c0d345dbf1aeef2e78082762181c6f992..00ed027613c6ce3bb0049548531cc85feb8b3dca 100644 (file)
--- a/lisp/term/xterm.el
+++ b/lisp/term/xterm.el
@@ -821,7 +821,7 @@ We run the first FUNCTION whose STRING matches the input events."
 
 (cl-defmethod gui-backend-get-selection
     (type data-type
-     &context (window-system (eql nil))
+     &context (window-system nil)
               ;; Only applies to terminals which have it enabled.
               ((terminal-parameter nil 'xterm--get-selection) (eql t)))
   (unless (eq data-type 'STRING)
@@ -844,7 +844,7 @@ We run the first FUNCTION whose STRING matches the input events."
 
 (cl-defmethod gui-backend-set-selection
     (type data
-     &context (window-system (eql nil))
+     &context (window-system nil)
               ;; Only applies to terminals which have it enabled.
               ((terminal-parameter nil 'xterm--set-selection) (eql t)))
   "Copy DATA to the X selection using the OSC 52 escape sequence.