scratch/fcr cf3e2fb: cl-print.el: Dispatch on `advice` type

[Stefan Monnier]

branch: scratch/fcr
commit cf3e2fb8afe88badfcde8aa8545dbd01cf533311
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>

    cl-print.el: Dispatch on `advice` type
    
    * test/lisp/emacs-lisp/nadvice-tests.el (advice-test-print): New test.
    
    * src/doc.c (store_function_docstring): Don't overwrite an FCR type.
    
    * lisp/simple.el (function-docstring): Don't return FCRs's type.
    
    * lisp/emacs-lisp/nadvice.el (advice--cl-print-object): New function,
    extracted from `cl-print-object`.
    
    * lisp/emacs-lisp/cl-print.el (cl-print-object) <advice>: Use the
    `advice` type for the dispatch.  Use `advice--cl-print-object`.
---
 lisp/emacs-lisp/cl-print.el           | 19 +++----------------
 lisp/emacs-lisp/nadvice.el            | 14 ++++++++++++++
 lisp/simple.el                        | 35 +++++++++++++++++++----------------
 src/doc.c                             |  6 +++++-
 test/lisp/emacs-lisp/nadvice-tests.el | 11 +++++++++++
 5 files changed, 52 insertions(+), 33 deletions(-)

diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el
index 348da59..047d198 100644
--- a/lisp/emacs-lisp/cl-print.el
+++ b/lisp/emacs-lisp/cl-print.el
@@ -225,22 +225,9 @@ into a button whose action shows the function's 
disassembly.")
 ;; complicated: cl-generic uses macros from cl-macs and cl-macs uses advice-add
 ;; from nadvice, so nadvice needs to be loaded before cl-generic and hence
 ;; can't use cl-defmethod.
-(cl-defmethod cl-print-object :extra "nadvice"
-              ((object compiled-function) stream)
-  (if (not (advice--p object))
-      (cl-call-next-method)
-    (princ "#f(advice-wrapper " stream)
-    (when (fboundp 'advice--where)
-      (princ (advice--where object) stream)
-      (princ " " stream))
-    (cl-print-object (advice--cdr object) stream)
-    (princ " " stream)
-    (cl-print-object (advice--car object) stream)
-    (let ((props (advice--props object)))
-      (when props
-        (princ " " stream)
-        (cl-print-object props stream)))
-    (princ ")" stream)))
+(cl-defmethod cl-print-object ((object advice) stream)
+  ;; FIXME: η-reduce!
+  (advice--cl-print-object object stream))
 
 (cl-defmethod cl-print-object ((object cl-structure-object) stream)
   (if (and cl-print--depth (natnump print-level)
diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el
index f75f527..b07bc74 100644
--- a/lisp/emacs-lisp/nadvice.el
+++ b/lisp/emacs-lisp/nadvice.el
@@ -184,6 +184,20 @@ function of type `advice'.")
     (when (or (commandp car) (commandp cdr))
       `(interactive ,(advice--make-interactive-form car cdr)))))
 
+(defun advice--cl-print-object (object stream)
+  (cl-assert (advice--p object))
+  (princ "#f(advice " stream)
+  (cl-print-object (advice--car object) stream)
+  (princ " " stream)
+  (princ (advice--where object) stream)
+  (princ " " stream)
+  (cl-print-object (advice--cdr object) stream)
+  (let ((props (advice--props object)))
+    (when props
+      (princ " " stream)
+      (cl-print-object props stream)))
+  (princ ")" stream))
+
 (defun advice--make (where function main props)
   "Build a function value that adds FUNCTION to MAIN at WHERE.
 WHERE is a symbol to select an entry in `advice--where-alist'."
diff --git a/lisp/simple.el b/lisp/simple.el
index bd1f4ba..cd9e239 100644
--- a/lisp/simple.el
+++ b/lisp/simple.el
@@ -2328,22 +2328,25 @@ maps."
 (cl-defgeneric function-docstring (function)
   "Extract the raw docstring info from FUNCTION.
 FUNCTION is expected to be a function value rather than, say, a mere symbol."
-  (pcase function
-   ((pred byte-code-function-p)
-    (if (> (length function) 4) (aref function 4)))
-   ((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 (or (stringp doc)
-                     (fixnump doc) (fixnump (cdr-safe doc)))
-                ;; Handle a doc reference--but these never come last
-                ;; in the function body, so reject them if they are last.
-                 (cdr body))
-        doc)))
-   (_ (signal 'invalid-function (list function)))))
+  (let ((docstring-p (lambda (doc) (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.
+                   (cdr body))
+           doc)))
+      (_ (signal 'invalid-function (list function))))))
 
 (cl-defgeneric interactive-form (cmd &optional original-name)
   "Return the interactive form of CMD or nil if none.
diff --git a/src/doc.c b/src/doc.c
index 1551dfa..336ca0b 100644
--- a/src/doc.c
+++ b/src/doc.c
@@ -465,7 +465,11 @@ store_function_docstring (Lisp_Object obj, EMACS_INT 
offset)
     {
       /* This bytecode object must have a slot for the
         docstring, since we've found a docstring for it.  */
-      if (PVSIZE (fun) > COMPILED_DOC_STRING)
+      if (PVSIZE (fun) > COMPILED_DOC_STRING
+         /* Don't overwrite a non-docstring value placed there,
+           * such as is used in FCRs.  */
+         && (FIXNUMP (AREF (fun, COMPILED_DOC_STRING))
+             || CONSP (AREF (fun, COMPILED_DOC_STRING))))
        ASET (fun, COMPILED_DOC_STRING, make_fixnum (offset));
       else
        {
diff --git a/test/lisp/emacs-lisp/nadvice-tests.el 
b/test/lisp/emacs-lisp/nadvice-tests.el
index 22125e6..cd59f44 100644
--- a/test/lisp/emacs-lisp/nadvice-tests.el
+++ b/test/lisp/emacs-lisp/nadvice-tests.el
@@ -204,6 +204,17 @@ function being an around advice."
     (remove-function (var sm-test10) sm-advice)
     (should (equal (funcall sm-test10 5) 15))))
 
+(ert-deftest advice-test-print ()
+  (let ((x (list 'cdr)))
+    (add-function :after (car x) 'car)
+    (should (equal (cl-prin1-to-string (car x))
+                   "#f(advice car :after cdr)"))
+    (add-function :before (car x) 'first)
+    (should (equal (cl-prin1-to-string (car x))
+                   "#f(advice first :before #f(advice car :after cdr))"))
+    (should (equal (cl-prin1-to-string (cadar advice--where-alist))
+                   "#f(advice nil :around nil)"))))
+
 ;; Local Variables:
 ;; no-byte-compile: t
 ;; End: