[Emacs-diffs] master 84dcdbe: * lisp/emacs-lisp/cl-generic.el: Add (major-mode MODE) context

[Stefan Monnier]

branch: master
commit 84dcdbeb740222a9e3da636b87a2b757acc11334
Author: Stefan Monnier <address@hidden>
Commit: Stefan Monnier <address@hidden>

    * 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.
---
 lisp/emacs-lisp/cl-generic.el |   45 +++++++++++++++++++++++++++++++++++++++++
 lisp/frame.el                 |    8 +++++-
 lisp/startup.el               |    2 +-
 lisp/term/ns-win.el           |   14 ++++++------
 lisp/term/pc-win.el           |   14 ++++++------
 lisp/term/w32-win.el          |   22 ++++++++++----------
 lisp/term/x-win.el            |   14 ++++++------
 lisp/term/xterm.el            |    4 +-
 8 files changed, 86 insertions(+), 37 deletions(-)

diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 0d7ef5b..aae517e 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:
diff --git a/lisp/frame.el b/lisp/frame.el
index b9e63d5..f550851 100644
--- 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 3385567..1346310 100644
--- 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 373f812..0b3e3bd 100644
--- 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 e8aaa1a..d2afaba 100644
--- 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 8bbc3dd..181fd49 100644
--- 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 5eb6f11..690401e 100644
--- 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 300e494..00ed027 100644
--- 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.