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

@@ -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)

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'."

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.

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
 	{

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: