master 39e8fd357d: OClosure: New function `function-documentation`

[Stefan Monnier]

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

    OClosure: New function `function-documentation`
    
    As mentioned in the original OClosure commit, OClosures (ab)use the
    bytecode's docstring slot to hold the OClosure's type.  This currently
    prevents OClosures from having their own docstring.
    
    Introduce a new generic function `function-documentation` to fetch the
    docstring of a function, which can then be implemented in various
    different ways depending on the OClosure's type.
    
    * lisp/simple.el (function-documentation): New generic function.
    (bad-package-check): Strength-reduce `eval` to `symbol-value`.
    * src/doc.c (Fdocumentation): Use it.
    
    * lisp/emacs-lisp/oclosure.el (oclosure--accessor-docstring): New function.
    * test/lisp/emacs-lisp/oclosure-tests.el (oclosure-test):
    Add test for accessor's docstrings.
---
 doc/lispref/help.texi                  |  7 +++++
 etc/NEWS                               |  6 ++++
 lisp/emacs-lisp/oclosure.el            |  6 ++++
 lisp/simple.el                         | 34 ++++++++++++++++++++++-
 src/doc.c                              | 50 +---------------------------------
 test/lisp/emacs-lisp/oclosure-tests.el |  1 +
 6 files changed, 54 insertions(+), 50 deletions(-)

diff --git a/doc/lispref/help.texi b/doc/lispref/help.texi
index 10a12940a1..d53bfad8e9 100644
--- a/doc/lispref/help.texi
+++ b/doc/lispref/help.texi
@@ -158,6 +158,13 @@ the function definition has no documentation string.  In 
that case,
 @code{documentation} returns @code{nil}.
 @end defun
 
+@defun function-documentation function
+Generic function used by @code{documentation} to extract the raw
+docstring from a function object.  You can specify how to get the
+docstring of a specific function type by adding a corresponding method
+to it.
+@end defun
+
 @defun face-documentation face
 This function returns the documentation string of @var{face} as a
 face.
diff --git a/etc/NEWS b/etc/NEWS
index 85ed817e05..1043873f2d 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1335,6 +1335,12 @@ This change is now applied in 'dired-insert-directory'.
 'unify-8859-on-decoding-mode', 'unify-8859-on-encoding-mode',
 'vc-arch-command'.
 
++++
+** New generic function 'function-doumentation'.
+Can dynamically generate a raw docstring depending on the type of
+a function.
+Used mainly for docstrings of OClosures.
+
 +++
 ** Base64 encoding no longer tolerates latin-1 input.
 The functions 'base64-encode-string', 'base64url-encode-string',
diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el
index 3df64ad280..90811199f2 100644
--- a/lisp/emacs-lisp/oclosure.el
+++ b/lisp/emacs-lisp/oclosure.el
@@ -505,6 +505,12 @@ This has 2 uses:
   "OClosure function to access a specific slot of an object."
   type slot)
 
+(defun oclosure--accessor-docstring (f)
+  ;; This would like to be a (cl-defmethod function-documentation ...)
+  ;; but for circularity reason the defmethod is in `simple.el'.
+  (format "Access slot \"%S\" of OBJ of type `%S'.\n\n(fn OBJ)"
+          (accessor--slot f) (accessor--type f)))
+
 (oclosure-define (oclosure-accessor
                   (:parent accessor)
                   (:copier oclosure--accessor-copy (type slot index)))
diff --git a/lisp/simple.el b/lisp/simple.el
index ef52006501..80c27d6e0e 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -2357,6 +2357,38 @@ maps."
   (with-suppressed-warnings ((interactive-only execute-extended-command))
     (execute-extended-command prefixarg command-name typed)))
 
+(cl-defgeneric function-documentation (function)
+  "Extract the raw docstring info from FUNCTION.
+FUNCTION is expected to be a function value rather than, say, a mere symbol.
+This is intended to be specialized via `cl-defmethod' but not called directly:
+if you need a function's documentation use `documentation' which will call this
+function as needed."
+  (let ((docstring-p (lambda (doc)
+                       ;; A docstring can be either a string or a reference
+                       ;; into either the `etc/DOC' or a `.elc' file.
+                       (or (stringp doc)
+                           (fixnump doc) (fixnump (cdr-safe doc))))))
+    (pcase function
+      ((pred byte-code-function-p)
+       (when (> (length function) 4)
+         (let ((doc (aref function 4)))
+           (when (funcall docstring-p doc) doc))))
+      ((or (pred stringp) (pred vectorp)) "Keyboard macro.")
+      (`(keymap . ,_)
+       "Prefix command (definition is a keymap associating keystrokes with 
commands).")
+      ((or `(lambda ,_args . ,body) `(closure ,_env ,_args . ,body)
+           `(autoload ,_file . ,body))
+       (let ((doc (car body)))
+        (when (and (funcall docstring-p doc)
+                   ;; Handle a doc reference--but these never come last
+                   ;; in the function body, so reject them if they are last.
+                   (or (cdr body) (eq 'autoload (car-safe function))))
+           doc)))
+      (_ (signal 'invalid-function (list function))))))
+
+(cl-defmethod function-documentation ((function accessor))
+  (oclosure--accessor-docstring function)) ;; FIXME: η-reduce!
+
 (defun command-execute (cmd &optional record-flag keys special)
   ;; BEWARE: Called directly from the C code.
   "Execute CMD as an editor command.
@@ -10007,7 +10039,7 @@ warning using STRING as the message.")
         (and list
              (boundp symbol)
              (or (eq symbol t)
-                 (and (stringp (setq symbol (eval symbol)))
+                 (and (stringp (setq symbol (symbol-value symbol)))
                       (string-match-p (nth 2 list) symbol)))
              (display-warning package (nth 3 list) :warning)))
     (error nil)))
diff --git a/src/doc.c b/src/doc.c
index e361a86c1a..5326195c6a 100644
--- a/src/doc.c
+++ b/src/doc.c
@@ -341,56 +341,8 @@ string is passed through `substitute-command-keys'.  */)
   else if (MODULE_FUNCTIONP (fun))
     doc = module_function_documentation (XMODULE_FUNCTION (fun));
 #endif
-  else if (COMPILEDP (fun))
-    {
-      if (PVSIZE (fun) <= COMPILED_DOC_STRING)
-       return Qnil;
-      else
-       {
-         Lisp_Object tem = AREF (fun, COMPILED_DOC_STRING);
-         if (STRINGP (tem))
-           doc = tem;
-         else if (FIXNATP (tem) || CONSP (tem))
-           doc = tem;
-         else
-           return Qnil;
-       }
-    }
-  else if (STRINGP (fun) || VECTORP (fun))
-    {
-      return build_string ("Keyboard macro.");
-    }
-  else if (CONSP (fun))
-    {
-      Lisp_Object funcar = XCAR (fun);
-      if (!SYMBOLP (funcar))
-       xsignal1 (Qinvalid_function, fun);
-      else if (EQ (funcar, Qkeymap))
-       return build_string ("Prefix command (definition is a keymap 
associating keystrokes with commands).");
-      else if (EQ (funcar, Qlambda)
-              || (EQ (funcar, Qclosure) && (fun = XCDR (fun), 1))
-              || EQ (funcar, Qautoload))
-       {
-         Lisp_Object tem1 = Fcdr (Fcdr (fun));
-         Lisp_Object tem = Fcar (tem1);
-         if (STRINGP (tem))
-           doc = tem;
-         /* Handle a doc reference--but these never come last
-            in the function body, so reject them if they are last.  */
-         else if ((FIXNATP (tem) || (CONSP (tem) && FIXNUMP (XCDR (tem))))
-                  && !NILP (XCDR (tem1)))
-           doc = tem;
-         else
-           return Qnil;
-       }
-      else
-       goto oops;
-    }
   else
-    {
-    oops:
-      xsignal1 (Qinvalid_function, fun);
-    }
+    doc = call1 (intern ("function-documentation"), fun);
 
   /* If DOC is 0, it's typically because of a dumped file missing
      from the DOC file (bug in src/Makefile.in).  */
diff --git a/test/lisp/emacs-lisp/oclosure-tests.el 
b/test/lisp/emacs-lisp/oclosure-tests.el
index d3e2b3870a..b6bdebc0a2 100644
--- a/test/lisp/emacs-lisp/oclosure-tests.el
+++ b/test/lisp/emacs-lisp/oclosure-tests.el
@@ -65,6 +65,7 @@
     (should (member (oclosure-test-gen ocl1)
                     '("#<oclosure-test:#<oclosure:#<cons>>>"
                       "#<oclosure-test:#<oclosure:#<bytecode>>>")))
+    (should (stringp (documentation #'oclosure-test--fst)))
     ))
 
 (ert-deftest oclosure-test-limits ()