scratch/command c010d9e 1/2: Add support for the new `command' special form

[Lars Ingebrigtsen]

branch: scratch/command
commit c010d9eef8365b370a16cea4eaac09816ecb03f8
Author: Lars Ingebrigtsen <larsi@gnus.org>
Commit: Lars Ingebrigtsen <larsi@gnus.org>

    Add support for the new `command' special form
---
 doc/lispref/commands.texi   | 18 +++++++++++
 lisp/emacs-lisp/bytecomp.el | 43 ++++++++++++++++----------
 lisp/emacs-lisp/edebug.el   |  3 ++
 lisp/simple.el              | 10 ++++++-
 src/callint.c               | 19 ++++++++++++
 src/data.c                  | 73 +++++++++++++++++++++++++++++++++++++++++----
 src/emacs-module.c          |  8 ++++-
 src/eval.c                  |  8 +++--
 src/lisp.h                  |  3 ++
 src/lread.c                 |  1 +
 10 files changed, 162 insertions(+), 24 deletions(-)

diff --git a/doc/lispref/commands.texi b/doc/lispref/commands.texi
index 3a2c7d0..a1d4d7e 100644
--- a/doc/lispref/commands.texi
+++ b/doc/lispref/commands.texi
@@ -116,6 +116,12 @@ serves as a flag, telling the Emacs command loop that the 
function can
 be called interactively.  The argument of the @code{interactive} form
 specifies how the arguments for an interactive call should be read.
 
+  Many commands are specific to certain major modes and do not make
+sense outside of that context.  These commands can be marked with
+@code{command} instead of @code{interactive}, and take an additional
+parameter that specifies the mode (or modes) the command is applicable
+for.
+
 @cindex @code{interactive-form} property
   Alternatively, an @code{interactive} form may be specified in a
 function symbol's @code{interactive-form} property.  A non-@code{nil}
@@ -186,6 +192,18 @@ interactive form to an existing function, or change how 
its arguments
 are processed interactively, without redefining the function.
 @end defspec
 
+@defspec command modes &optional arg-descriptor
+The @code{command} special form is identical to @code{interactive} in
+its effect, but allows specifying which modes the command is meant to
+be used in.  This affects, for instance, completion in @kbd{M-x}
+(commands won't be offered as completions if they don't match (using
+@code{derived-mode-p}) the current major mode), and will make
+@kbd{C-h m} list these commands.
+
+@var{modes} can be either a single symbol (a mode name), or a list of
+symbols (several mode names).
+@end defspec
+
 There are three possibilities for the argument @var{arg-descriptor}:
 
 @itemize @bullet
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 89068a1..e59a1f5 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -2939,7 +2939,9 @@ for symbols generated by the byte compiler itself."
                     ;; unless it is the last element of the body.
                     (if (cdr body)
                         (setq body (cdr body))))))
-        (int (assq 'interactive body)))
+        (int (or (assq 'interactive body)
+                  (assq 'command body)))
+         command-modes)
     (when lexical-binding
       (dolist (var arglistvars)
         (when (assq var byte-compile--known-dynamic-vars)
@@ -2951,27 +2953,37 @@ for symbols generated by the byte compiler itself."
       (if (eq int (car body))
          (setq body (cdr body)))
       (cond ((consp (cdr int))
-            (if (cdr (cdr int))
-                (byte-compile-warn "malformed interactive spec: %s"
-                                   (prin1-to-string int)))
+            (when (or (and (eq (car int) 'interactive)
+                            (cdr (cdr int)))
+                       (and (eq (car int) 'command)
+                            (cdr (cdr (cdr int)))))
+              (byte-compile-warn "malformed interactive spec: %s"
+                                 (prin1-to-string int)))
+             (when (eq (car int) 'command)
+               (setq command-modes (cadr int))
+               (unless (listp command-modes)
+                 (setq command-modes (list command-modes))))
             ;; If the interactive spec is a call to `list', don't
             ;; compile it, because `call-interactively' looks at the
             ;; args of `list'.  Actually, compile it to get warnings,
             ;; but don't use the result.
-            (let* ((form (nth 1 int))
+            (let* ((form (if (eq (car int) 'interactive)
+                              (nth 1 int)
+                            (nth 2 int)))
                     (newform (byte-compile-top-level form)))
               (while (memq (car-safe form) '(let let* progn save-excursion))
                 (while (consp (cdr form))
                   (setq form (cdr form)))
                 (setq form (car form)))
-              (if (and (eq (car-safe form) 'list)
-                        ;; For code using lexical-binding, form is not
-                        ;; valid lisp, but rather an intermediate form
-                        ;; which may include "calls" to
-                        ;; internal-make-closure (Bug#29988).
-                        (not lexical-binding))
-                  nil
-                (setq int `(interactive ,newform)))))
+              (setq int
+                    (if (and (eq (car-safe form) 'list)
+                              ;; For code using lexical-binding, form is not
+                              ;; valid lisp, but rather an intermediate form
+                              ;; which may include "calls" to
+                              ;; internal-make-closure (Bug#29988).
+                              (not lexical-binding))
+                         `(interactive ,form)
+                       `(interactive ,newform)))))
            ((cdr int)
             (byte-compile-warn "malformed interactive spec: %s"
                                (prin1-to-string int)))))
@@ -3002,9 +3014,10 @@ for symbols generated by the byte compiler itself."
                      (list (help-add-fundoc-usage doc arglist)))
                     ((or doc int)
                      (list doc)))
-              ;; optionally, the interactive spec.
+              ;; optionally, the interactive spec (and the modes the
+              ;; command applies to).
               (if int
-                  (list (nth 1 int))))))))
+                  (list (cons (nth 1 int) command-modes))))))))
 
 (defvar byte-compile-reserved-constants 0)
 
diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el
index 0733dce..3c86b2e 100644
--- a/lisp/emacs-lisp/edebug.el
+++ b/lisp/emacs-lisp/edebug.el
@@ -2211,6 +2211,9 @@ into `edebug--cl-macrolet-defs' which is checked in 
`edebug-list-form-args'."
 (def-edebug-spec interactive
   (&optional &or stringp def-form))
 
+(def-edebug-spec command
+  (symbolp [&optional &or stringp def-form]))
+
 ;; A function-form is for an argument that may be a function or a form.
 ;; This specially recognizes anonymous functions quoted with quote.
 (def-edebug-spec function-form
diff --git a/lisp/simple.el b/lisp/simple.el
index 0c5bcb6..fbd23a0 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -1948,7 +1948,15 @@ to get different commands to edit and resubmit."
             (affixation-function . read-extended-command--affixation)
             (category . command))
          (complete-with-action action obarray string pred)))
-     #'commandp t nil 'extended-command-history)))
+     #'command-for-mode-p t nil 'extended-command-history)))
+
+(defun command-for-mode-p (symbol)
+  "Say whether SYMBOL should be offered as a completion.
+This is true if it's a command and the command is applicable to
+the current major mode."
+  (and (commandp symbol)
+       (or (null (command-modes symbol))
+           (apply #'derived-mode-p (command-modes symbol)))))
 
 (defun read-extended-command--affixation (command-names)
   (with-selected-window (or (minibuffer-selected-window) (selected-window))
diff --git a/src/callint.c b/src/callint.c
index d3f49bc..ba5a406 100644
--- a/src/callint.c
+++ b/src/callint.c
@@ -111,6 +111,24 @@ usage: (interactive &optional ARG-DESCRIPTOR)  */
   return Qnil;
 }
 
+DEFUN ("command", Fcommand, Scommand, 0, UNEVALLED, 0,
+       doc: /* Specify interactive arguments for a mode-specific command.
+This is like `interactive' (which see), except that it allows
+specifying which major mode (or modes) the command is meant for.  This
+has the effect of limiting completion in commands like `M-x' to the
+relevant commands for the current mode, and will also make `C-h m' list
+these commands.
+
+MODES can be either a symbol (a single mode), or a list of symbols
+(several modes).
+
+usage: (command MODES &optional ARG-DESCRIPTOR)  */
+       attributes: const)
+  (Lisp_Object args)
+{
+  return Qnil;
+}
+
 /* Quotify EXP: if EXP is constant, return it.
    If EXP is not constant, return (quote EXP).  */
 static Lisp_Object
@@ -891,6 +909,7 @@ a way to turn themselves off when a mouse command switches 
windows.  */);
   Vmouse_leave_buffer_hook = Qnil;
 
   defsubr (&Sinteractive);
+  defsubr (&Scommand);
   defsubr (&Scall_interactively);
   defsubr (&Sfuncall_interactively);
   defsubr (&Sprefix_numeric_value);
diff --git a/src/data.c b/src/data.c
index 38cde0f..eac2488 100644
--- a/src/data.c
+++ b/src/data.c
@@ -904,7 +904,7 @@ Value, if non-nil, is a list (interactive SPEC).  */)
   else if (COMPILEDP (fun))
     {
       if (PVSIZE (fun) > COMPILED_INTERACTIVE)
-       return list2 (Qinteractive, AREF (fun, COMPILED_INTERACTIVE));
+       return list2 (Qinteractive, Fcar (AREF (fun, COMPILED_INTERACTIVE)));
     }
 #ifdef HAVE_MODULES
   else if (MODULE_FUNCTIONP (fun))
@@ -920,10 +920,71 @@ Value, if non-nil, is a list (interactive SPEC).  */)
   else if (CONSP (fun))
     {
       Lisp_Object funcar = XCAR (fun);
-      if (EQ (funcar, Qclosure))
-       return Fassq (Qinteractive, Fcdr (Fcdr (XCDR (fun))));
-      else if (EQ (funcar, Qlambda))
-       return Fassq (Qinteractive, Fcdr (XCDR (fun)));
+      if (EQ (funcar, Qclosure)
+         || EQ (funcar, Qlambda))
+       {
+         Lisp_Object form = Fcdr (XCDR (fun));
+         if (EQ (funcar, Qclosure))
+           form = Fcdr (form);
+         Lisp_Object spec = Fassq (Qcommand, form);
+         if (!NILP (spec))
+           return Fcons (Qinteractive, Fcdr (Fcdr (spec)));
+         else
+           return Fassq (Qinteractive, form);
+       }
+    }
+  return Qnil;
+}
+
+DEFUN ("command-modes", Fcommand_modes, Scommand_modes, 1, 1, 0,
+       doc: /* Return the modes COMMAND is defined for.
+If COMMAND is not a command, the return value is nil.
+The value, if non-nil, is a list of mode name symbols.  */)
+  (Lisp_Object command)
+{
+  Lisp_Object fun = indirect_function (command); /* Check cycles.  */
+
+  if (NILP (fun))
+    return Qnil;
+
+  fun = command;
+  while (SYMBOLP (fun))
+    fun = Fsymbol_function (fun);
+
+  if (SUBRP (fun))
+    {
+      if (!NILP (XSUBR (fun)->command_modes))
+       return XSUBR (fun)->command_modes;
+    }
+  else if (COMPILEDP (fun))
+    {
+      if (PVSIZE (fun) > COMPILED_INTERACTIVE)
+       return Fcdr (AREF (fun, COMPILED_INTERACTIVE));
+    }
+#ifdef HAVE_MODULES
+  else if (MODULE_FUNCTIONP (fun))
+    {
+      Lisp_Object form
+        = module_function_command_modes (XMODULE_FUNCTION (fun));
+      if (! NILP (form))
+        return form;
+    }
+#endif
+  else if (AUTOLOADP (fun))
+    return Fcommand_modes (Fautoload_do_load (fun, command, Qnil));
+  else if (CONSP (fun))
+    {
+      Lisp_Object funcar = XCAR (fun);
+      if (EQ (funcar, Qclosure)
+         || EQ (funcar, Qlambda))
+       {
+         Lisp_Object form = Fcdr (XCDR (fun));
+         if (EQ (funcar, Qclosure))
+           form = Fcdr (form);
+         Lisp_Object spec = Fassq (Qcommand, form);
+         if (spec)
+           return list1 (Fcar (Fcdr (spec)));
+       }
     }
   return Qnil;
 }
@@ -3908,6 +3969,7 @@ syms_of_data (void)
 
   defsubr (&Sindirect_variable);
   defsubr (&Sinteractive_form);
+  defsubr (&Scommand_modes);
   defsubr (&Seq);
   defsubr (&Snull);
   defsubr (&Stype_of);
@@ -4030,6 +4092,7 @@ This variable cannot be set; trying to do so will signal 
an error.  */);
   DEFSYM (Qunlet, "unlet");
   DEFSYM (Qset, "set");
   DEFSYM (Qset_default, "set-default");
+  DEFSYM (Qcommand_modes, "command-modes");
   defsubr (&Sadd_variable_watcher);
   defsubr (&Sremove_variable_watcher);
   defsubr (&Sget_variable_watchers);
diff --git a/src/emacs-module.c b/src/emacs-module.c
index 894dffc..f8fb54c 100644
--- a/src/emacs-module.c
+++ b/src/emacs-module.c
@@ -549,7 +549,7 @@ struct Lisp_Module_Function
   union vectorlike_header header;
 
   /* Fields traced by GC; these must come first.  */
-  Lisp_Object documentation, interactive_form;
+  Lisp_Object documentation, interactive_form, command_modes;
 
   /* Fields ignored by GC.  */
   ptrdiff_t min_arity, max_arity;
@@ -646,6 +646,12 @@ module_function_interactive_form (const struct 
Lisp_Module_Function *fun)
   return fun->interactive_form;
 }
 
+Lisp_Object
+module_function_command_modes (const struct Lisp_Module_Function *fun)
+{
+  return fun->command_modes;
+}
+
 static emacs_value
 module_funcall (emacs_env *env, emacs_value func, ptrdiff_t nargs,
                emacs_value *args)
diff --git a/src/eval.c b/src/eval.c
index 3aff3b5..869a283 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -2072,9 +2072,12 @@ then strings and vectors are not accepted.  */)
   funcar = XCAR (fun);
   if (EQ (funcar, Qclosure))
     return (!NILP (Fassq (Qinteractive, Fcdr (Fcdr (XCDR (fun)))))
-           ? Qt : if_prop);
+           || !NILP (Fassq (Qcommand, Fcdr (Fcdr (XCDR (fun))))))
+      ? Qt : if_prop;
   else if (EQ (funcar, Qlambda))
-    return !NILP (Fassq (Qinteractive, Fcdr (XCDR (fun)))) ? Qt : if_prop;
+    return (!NILP (Fassq (Qinteractive, Fcdr (XCDR (fun))))
+           || !NILP (Fassq (Qcommand, Fcdr (XCDR (fun)))))
+      ? Qt : if_prop;
   else if (EQ (funcar, Qautoload))
     return !NILP (Fcar (Fcdr (Fcdr (XCDR (fun))))) ? Qt : if_prop;
   else
@@ -4224,6 +4227,7 @@ before making `inhibit-quit' nil.  */);
   DEFSYM (Qexit, "exit");
 
   DEFSYM (Qinteractive, "interactive");
+  DEFSYM (Qcommand, "command");
   DEFSYM (Qcommandp, "commandp");
   DEFSYM (Qand_rest, "&rest");
   DEFSYM (Qand_optional, "&optional");
diff --git a/src/lisp.h b/src/lisp.h
index 409a1e7..5710112 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -2060,6 +2060,7 @@ struct Lisp_Subr
     const char *symbol_name;
     const char *intspec;
     EMACS_INT doc;
+    Lisp_Object command_modes;
   } GCALIGNED_STRUCT;
 union Aligned_Lisp_Subr
   {
@@ -4220,6 +4221,8 @@ extern Lisp_Object module_function_documentation
   (struct Lisp_Module_Function const *);
 extern Lisp_Object module_function_interactive_form
   (const struct Lisp_Module_Function *);
+extern Lisp_Object module_function_command_modes
+  (const struct Lisp_Module_Function *);
 extern module_funcptr module_function_address
   (struct Lisp_Module_Function const *);
 extern void *module_function_data (const struct Lisp_Module_Function *);
diff --git a/src/lread.c b/src/lread.c
index dea1b23..8b8ba93 100644
--- a/src/lread.c
+++ b/src/lread.c
@@ -4467,6 +4467,7 @@ defsubr (union Aligned_Lisp_Subr *aname)
   XSETPVECTYPE (sname, PVEC_SUBR);
   XSETSUBR (tem, sname);
   set_symbol_function (sym, tem);
+  sname->command_modes = Qnil;
 }
 
 #ifdef NOTDEF /* Use fset in subr.el now!  */