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 OClosure type.

* lisp/simple.el (function-docstring): Don't return OClosures'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`.

diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el
index 348da59fd977fa8bd1aec5b9ced85a9efcb5519e..047d19885951d729c4774d759680ffba564542c1 100644 (file)
--- 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 ebedfa9c1226717b192c663054b1d079092e69ac..ea6b4d73d3c6bfb1e7c2e64063afd8374d15e8e8 100644 (file)
--- 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 bd1f4ba9690ccf6bf8b6d705170f17d8a8790129..cd9e2396fd69399b24fadee9fc1026445f2bc072 100644 (file)
--- 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 1551dfa06e714649cce8e2d00db41ce168e1b7d2..336ca0b85243e9afafc11d03d8f716a71168aed5 100644 (file)
--- 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 22125e6f9ffec156da5458891f6df5110d642d08..cd59f44033482eaad4a35f7cdb88bd02c1743994 100644 (file)
--- 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: