bug#54732: 29.0.50; New `function-documentation`

[Stefan Monnier]

Package: Emacs
Version: 29.0.50

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.

The patch below lifts this restriction by introducing 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.

The patch includes one such use, tho there will be others.
[ I thought I had sent this patch a few days ago but can't find it on
  debbugs, so something must have gone wrong on my end when i sent it.
  In that earlier version the function was called
  `function-docstring`.  ]

Comments?  Objections?


        Stefan


2022-04-05  Stefan Monnier  <monnier@iro.umontreal.ca>

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


diff --git a/doc/lispref/help.texi b/doc/lispref/help.texi
index 10a12940a15..d53bfad8e9e 100644
--- a/doc/lispref/help.texi
+++ b/doc/lispref/help.texi
@@ -158,6 +158,13 @@ Accessing Documentation
 @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 640e18c6bdc..d138f5f68f7 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1314,6 +1314,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 3df64ad2806..90811199f25 100644
--- a/lisp/emacs-lisp/oclosure.el
+++ b/lisp/emacs-lisp/oclosure.el
@@ -505,6 +505,12 @@ accessor
   "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 7918767a756..9416a13b7ab 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -2357,6 +2357,37 @@ execute-extended-command-for-buffer
   (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.
+It is usually preferable to call `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.
@@ -9980,7 +10011,7 @@ bad-package-check
         (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 e361a86c1a1..5326195c6a0 100644
--- a/src/doc.c
+++ b/src/doc.c
@@ -341,56 +341,8 @@ DEFUN ("documentation", Fdocumentation, Sdocumentation, 1, 
2, 0,
   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 d3e2b3870a6..b6bdebc0a2b 100644
--- a/test/lisp/emacs-lisp/oclosure-tests.el
+++ b/test/lisp/emacs-lisp/oclosure-tests.el
@@ -65,6 +65,7 @@ oclosure-test
     (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 ()