master bffc4cb39d: New generic function `oclosure-interactive-form`

[Stefan Monnier]

branch: master
commit bffc4cb39dc7b83fc4a1bffd23eeed2774b79444
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>

    New generic function `oclosure-interactive-form`
    
    It's used by `interactive-form` when it encounters an OClosure.
    This lets one compute the `interactive-form` of OClosures
    dynamically by adding appropriate methods.
    This does not include support for `command-modes` for Oclosures.
    
    * lisp/simple.el (oclosure-interactive-form): New generic function.
    
    * src/data.c (Finteractive_form): Delegate to
    `oclosure-interactive-form` if the arg is an OClosure.
    (syms_of_data): New symbol `Qoclosure_interactive_form`.
    * src/eval.c (Fcommandp): Delegate to `interactive-form` if the arg is
    an OClosure.
    
    * src/lisp.h (VALID_DOCSTRING_P): New function, extracted from
    `store_function_docstring`.
    * src/doc.c (store_function_docstring): Use it.
    
    * lisp/kmacro.el (kmacro): Don't carry any interactive form.
    (oclosure-interactive-form) <kmacro>: New method, instead.
    
    * test/lisp/emacs-lisp/oclosure-tests.el (oclosure-interactive-form)
    <oclosure-test>: New method.
    (oclosure-test-interactive-form): New test.
    
    * doc/lispref/commands.texi (Using Interactive):
    Document `oclosure-interactive-form`.
---
 doc/lispref/commands.texi              | 19 +++++++
 etc/NEWS                               |  5 ++
 lisp/kmacro.el                         |  3 +-
 lisp/simple.el                         | 11 ++++
 src/callint.c                          |  2 +-
 src/data.c                             | 32 ++++++++----
 src/doc.c                              |  4 +-
 src/eval.c                             | 94 +++++++++++++++++++++++-----------
 src/lisp.h                             | 10 ++++
 test/lisp/emacs-lisp/oclosure-tests.el | 21 ++++++++
 10 files changed, 157 insertions(+), 44 deletions(-)

diff --git a/doc/lispref/commands.texi b/doc/lispref/commands.texi
index ace0c02551..6c60216796 100644
--- a/doc/lispref/commands.texi
+++ b/doc/lispref/commands.texi
@@ -312,6 +312,25 @@ If @var{function} is an interactively callable function
 specifies how to compute its arguments.  Otherwise, the value is
 @code{nil}.  If @var{function} is a symbol, its function definition is
 used.
+When called on an OClosure, the work is delegated to the generic
+function @code{oclosure-interactive-form}.
+@end defun
+
+@defun oclosure-interactive-form function
+Just like @code{interactive-form}, this function takes a command and
+returns its interactive form.  The difference is that it is a generic
+function and it is only called when @var{function} is an OClosure.
+The purpose is to make it possible for some OClosure types to compute
+their interactive forms dynamically instead of carrying it in one of
+their slots.
+
+This is used for example for @code{kmacro} functions in order to
+reduce their memory size, since they all share the same interactive
+form.  It is also used for @code{advice} functions, where the
+interactive form is computed from the interactive forms of its
+components, so as to make this computation more lazily and to
+correctly adjust the interactive form when one of its component's
+is redefined.
 @end defun
 
 @node Interactive Codes
diff --git a/etc/NEWS b/etc/NEWS
index dc2e7c616a..19434ec85b 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1345,6 +1345,11 @@ remote host are shown.  Alternatively, the user option
 Allows the creation of "functions with slots" or "function objects"
 via the macros 'oclosure-define' and 'oclosure-lambda'.
 
+*** New generic function 'oclosure-interactive-form'.
+Used by 'interactive-form' when called on an OClosure.
+This allows specific OClosure types to compute their interactive specs
+on demand rather than precompute them when created.
+
 ---
 ** New theme 'leuven-dark'.
 This is a dark version of the 'leuven' theme.
diff --git a/lisp/kmacro.el b/lisp/kmacro.el
index 8a9d89929e..5476c2395c 100644
--- a/lisp/kmacro.el
+++ b/lisp/kmacro.el
@@ -820,13 +820,14 @@ KEYS should be a vector or a string that obeys 
`key-valid-p'."
                            (counter (or counter 0))
                            (format (or format "%d")))
       (&optional arg)
-    (interactive "p")
     ;; Use counter and format specific to the macro on the ring!
     (let ((kmacro-counter counter)
          (kmacro-counter-format-start format))
       (execute-kbd-macro keys arg #'kmacro-loop-setup-function)
       (setq counter kmacro-counter))))
 
+(cl-defmethod oclosure-interactive-form ((_ kmacro)) '(interactive "p"))
+
 ;;;###autoload
 (defun kmacro-lambda-form (mac &optional counter format)
   ;; Apparently, there are two different ways this is called:
diff --git a/lisp/simple.el b/lisp/simple.el
index 1ff101cfcd..d638e641c3 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -2389,6 +2389,17 @@ function as needed."
 (cl-defmethod function-documentation ((function accessor))
   (oclosure--accessor-docstring function)) ;; FIXME: η-reduce!
 
+;; This should be in `oclosure.el' but that file is loaded before `cl-generic'.
+(cl-defgeneric oclosure-interactive-form (_function)
+  "Return the interactive form of FUNCTION or nil if none.
+This is called by `interactive-form' when invoked on OClosures.
+It should return either nil or a two-element list of the form (interactive 
FORM)
+where FORM is like the first arg of the `interactive' special form.
+Add your methods to this generic function, but always call `interactive-form'
+instead."
+  ;; (interactive-form function)
+  nil)
+
 (defun command-execute (cmd &optional record-flag keys special)
   ;; BEWARE: Called directly from the C code.
   "Execute CMD as an editor command.
diff --git a/src/callint.c b/src/callint.c
index 31919d6bb8..92bfaf8d39 100644
--- a/src/callint.c
+++ b/src/callint.c
@@ -315,7 +315,7 @@ invoke it (via an `interactive' spec that contains, for 
instance, an
   Lisp_Object up_event = Qnil;
 
   /* Set SPECS to the interactive form, or barf if not interactive.  */
-  Lisp_Object form = Finteractive_form (function);
+  Lisp_Object form = call1 (Qinteractive_form, function);
   if (! CONSP (form))
     wrong_type_argument (Qcommandp, function);
   Lisp_Object specs = Fcar (XCDR (form));
diff --git a/src/data.c b/src/data.c
index 72af8a6648..0347ff363c 100644
--- a/src/data.c
+++ b/src/data.c
@@ -1072,6 +1072,7 @@ Value, if non-nil, is a list (interactive SPEC).  */)
   (Lisp_Object cmd)
 {
   Lisp_Object fun = indirect_function (cmd); /* Check cycles.  */
+  bool genfun = false;
 
   if (NILP (fun))
     return Qnil;
@@ -1104,15 +1105,17 @@ Value, if non-nil, is a list (interactive SPEC).  */)
       if (PVSIZE (fun) > COMPILED_INTERACTIVE)
        {
          Lisp_Object form = AREF (fun, COMPILED_INTERACTIVE);
-         if (VECTORP (form))
-           /* The vector form is the new form, where the first
-              element is the interactive spec, and the second is the
-              command modes. */
-           return list2 (Qinteractive, AREF (form, 0));
-         else
-           /* Old form -- just the interactive spec. */
-           return list2 (Qinteractive, form);
+         /* The vector form is the new form, where the first
+            element is the interactive spec, and the second is the
+            command modes. */
+         return list2 (Qinteractive, VECTORP (form) ? AREF (form, 0) : form);
        }
+      else if (PVSIZE (fun) > COMPILED_DOC_STRING)
+        {
+          Lisp_Object doc = AREF (fun, COMPILED_DOC_STRING);
+          /* An invalid "docstring" is a sign that we have an OClosure.  */
+          genfun = !(NILP (doc) || VALID_DOCSTRING_P (doc));
+        }
     }
 #ifdef HAVE_MODULES
   else if (MODULE_FUNCTIONP (fun))
@@ -1135,13 +1138,21 @@ Value, if non-nil, is a list (interactive SPEC).  */)
          if (EQ (funcar, Qclosure))
            form = Fcdr (form);
          Lisp_Object spec = Fassq (Qinteractive, form);
-         if (NILP (Fcdr (Fcdr (spec))))
+         if (NILP (spec) && VALID_DOCSTRING_P (CAR_SAFE (form)))
+            /* A "docstring" is a sign that we may have an OClosure.  */
+           genfun = true;
+         else if (NILP (Fcdr (Fcdr (spec))))
            return spec;
          else
            return list2 (Qinteractive, Fcar (Fcdr (spec)));
        }
     }
-  return Qnil;
+  if (genfun
+      /* Avoid burping during bootstrap.  */
+      && !NILP (Fsymbol_function (Qoclosure_interactive_form)))
+    return call1 (Qoclosure_interactive_form, fun);
+  else
+    return Qnil;
 }
 
 DEFUN ("command-modes", Fcommand_modes, Scommand_modes, 1, 1, 0,
@@ -4123,6 +4134,7 @@ syms_of_data (void)
   DEFSYM (Qchar_table_p, "char-table-p");
   DEFSYM (Qvector_or_char_table_p, "vector-or-char-table-p");
   DEFSYM (Qfixnum_or_symbol_with_pos_p, "fixnum-or-symbol-with-pos-p");
+  DEFSYM (Qoclosure_interactive_form, "oclosure-interactive-form");
 
   DEFSYM (Qsubrp, "subrp");
   DEFSYM (Qunevalled, "unevalled");
diff --git a/src/doc.c b/src/doc.c
index 5326195c6a..71e66853b0 100644
--- a/src/doc.c
+++ b/src/doc.c
@@ -469,9 +469,7 @@ store_function_docstring (Lisp_Object obj, EMACS_INT offset)
       if (PVSIZE (fun) > COMPILED_DOC_STRING
          /* Don't overwrite a non-docstring value placed there,
            * such as the symbols used for Oclosures.  */
-         && (FIXNUMP (AREF (fun, COMPILED_DOC_STRING))
-             || STRINGP (AREF (fun, COMPILED_DOC_STRING))
-             || CONSP (AREF (fun, COMPILED_DOC_STRING))))
+         && VALID_DOCSTRING_P (AREF (fun, COMPILED_DOC_STRING)))
        ASET (fun, COMPILED_DOC_STRING, make_fixnum (offset));
       else
        {
diff --git a/src/eval.c b/src/eval.c
index 37bc03465c..77ec47e2b7 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -2032,8 +2032,7 @@ then strings and vectors are not accepted.  */)
   (Lisp_Object function, Lisp_Object for_call_interactively)
 {
   register Lisp_Object fun;
-  register Lisp_Object funcar;
-  Lisp_Object if_prop = Qnil;
+  bool genfun = false; /* If true, we should consult `interactive-form'.  */
 
   fun = function;
 
@@ -2041,52 +2040,89 @@ then strings and vectors are not accepted.  */)
   if (NILP (fun))
     return Qnil;
 
-  /* Check an `interactive-form' property if present, analogous to the
-     function-documentation property.  */
-  fun = function;
-  while (SYMBOLP (fun))
-    {
-      Lisp_Object tmp = Fget (fun, Qinteractive_form);
-      if (!NILP (tmp))
-       if_prop = Qt;
-      fun = Fsymbol_function (fun);
-    }
-
   /* Emacs primitives are interactive if their DEFUN specifies an
      interactive spec.  */
   if (SUBRP (fun))
-    return XSUBR (fun)->intspec.string ? Qt : if_prop;
-
+    {
+      if (XSUBR (fun)->intspec.string)
+        return Qt;
+    }
   /* Bytecode objects are interactive if they are long enough to
      have an element whose index is COMPILED_INTERACTIVE, which is
      where the interactive spec is stored.  */
   else if (COMPILEDP (fun))
-    return (PVSIZE (fun) > COMPILED_INTERACTIVE ? Qt : if_prop);
+    {
+      if (PVSIZE (fun) > COMPILED_INTERACTIVE)
+        return Qt;
+      else if (PVSIZE (fun) > COMPILED_DOC_STRING)
+        {
+          Lisp_Object doc = AREF (fun, COMPILED_DOC_STRING);
+          /* An invalid "docstring" is a sign that we have an OClosure.  */
+          genfun = !(NILP (doc) || VALID_DOCSTRING_P (doc));
+        }
+    }
 
 #ifdef HAVE_MODULES
   /* Module functions are interactive if their `interactive_form'
      field is non-nil. */
   else if (MODULE_FUNCTIONP (fun))
-    return NILP (module_function_interactive_form (XMODULE_FUNCTION (fun)))
-             ? if_prop
-             : Qt;
+    {
+      if (!NILP (module_function_interactive_form (XMODULE_FUNCTION (fun))))
+        return Qt;
+    }
 #endif
 
   /* Strings and vectors are keyboard macros.  */
-  if (STRINGP (fun) || VECTORP (fun))
+  else if (STRINGP (fun) || VECTORP (fun))
     return (NILP (for_call_interactively) ? Qt : Qnil);
 
   /* Lists may represent commands.  */
-  if (!CONSP (fun))
+  else if (!CONSP (fun))
     return Qnil;
-  funcar = XCAR (fun);
-  if (EQ (funcar, Qclosure))
-    return (!NILP (Fassq (Qinteractive, Fcdr (Fcdr (XCDR (fun)))))
-           ? Qt : if_prop);
-  else if (EQ (funcar, Qlambda))
-    return !NILP (Fassq (Qinteractive, Fcdr (XCDR (fun)))) ? Qt : if_prop;
-  else if (EQ (funcar, Qautoload))
-    return !NILP (Fcar (Fcdr (Fcdr (XCDR (fun))))) ? Qt : if_prop;
+  else
+    {
+      Lisp_Object funcar = XCAR (fun);
+      if (EQ (funcar, Qautoload))
+        {
+          if (!NILP (Fcar (Fcdr (Fcdr (XCDR (fun))))))
+            return Qt;
+        }
+      else
+        {
+          Lisp_Object body = CDR_SAFE (XCDR (fun));
+          if (EQ (funcar, Qclosure))
+            body = CDR_SAFE (body);
+          else if (!EQ (funcar, Qlambda))
+           return Qnil;
+         if (!NILP (Fassq (Qinteractive, body)))
+           return Qt;
+         else if (VALID_DOCSTRING_P (CAR_SAFE (body)))
+            /* A "docstring" is a sign that we may have an OClosure.  */
+           genfun = true;
+       }
+    }
+
+  /* By now, if it's not a function we already returned nil.  */
+
+  /* Check an `interactive-form' property if present, analogous to the
+     function-documentation property.  */
+  fun = function;
+  while (SYMBOLP (fun))
+    {
+      Lisp_Object tmp = Fget (fun, Qinteractive_form);
+      if (!NILP (tmp))
+       error ("Found an 'interactive-form' property!");
+      fun = Fsymbol_function (fun);
+    }
+
+  /* If there's no immediate interactive form but it's an OClosure,
+     then delegate to the generic-function in case it has
+     a type-specific interactive-form.  */
+  if (genfun)
+    {
+      Lisp_Object iform = call1 (Qinteractive_form, fun);
+      return NILP (iform) ? Qnil : Qt;
+    }
   else
     return Qnil;
 }
diff --git a/src/lisp.h b/src/lisp.h
index 75f369f524..1ad89fc468 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -2185,6 +2185,16 @@ XSUBR (Lisp_Object a)
   return &XUNTAG (a, Lisp_Vectorlike, union Aligned_Lisp_Subr)->s;
 }
 
+/* Return whether a value might be a valid docstring.
+   Used to distinguish the presence of non-docstring in the docstring slot,
+   as in the case of OClosures.  */
+INLINE bool
+VALID_DOCSTRING_P (Lisp_Object doc)
+{
+  return FIXNUMP (doc) || STRINGP (doc)
+         || (CONSP (doc) && STRINGP (XCAR (doc)) && FIXNUMP (XCDR (doc)));
+}
+
 enum char_table_specials
   {
     /* This is the number of slots that every char table must have.  This
diff --git a/test/lisp/emacs-lisp/oclosure-tests.el 
b/test/lisp/emacs-lisp/oclosure-tests.el
index b6bdebc0a2..b3a921826b 100644
--- a/test/lisp/emacs-lisp/oclosure-tests.el
+++ b/test/lisp/emacs-lisp/oclosure-tests.el
@@ -106,6 +106,27 @@
       (and (eq 'error (car err))
            (string-match "Duplicate slot: fst$" (cadr err)))))))
 
+(cl-defmethod oclosure-interactive-form ((ot oclosure-test))
+  (let ((snd (oclosure-test--snd ot)))
+    (if (stringp snd) (list 'interactive snd))))
+
+(ert-deftest oclosure-test-interactive-form ()
+  (should (equal (interactive-form
+                  (oclosure-lambda (oclosure-test (fst 1) (snd 2)) () fst))
+                 nil))
+  (should (equal (interactive-form
+                  (oclosure-lambda (oclosure-test (fst 1) (snd 2)) ()
+                    (interactive "r")
+                    fst))
+                 '(interactive "r")))
+  (should (equal (interactive-form
+                  (oclosure-lambda (oclosure-test (fst 1) (snd "P")) () fst))
+                 '(interactive "P")))
+  (should (not (commandp
+                (oclosure-lambda (oclosure-test (fst 1) (snd 2)) () fst))))
+  (should (commandp
+           (oclosure-lambda (oclosure-test (fst 1) (snd "P")) () fst))))
+
 (oclosure-define (oclosure-test-mut
                   (:parent oclosure-test)
                   (:copier oclosure-test-mut-copy))