From afa68def26a041a63402ae43dcaa056d6439a62d Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sat, 18 Dec 2021 19:20:25 -0500 Subject: [PATCH] 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) : 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 348da59fd97..047d1988595 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 ebedfa9c122..ea6b4d73d3c 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 bd1f4ba9690..cd9e2396fd6 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 1551dfa06e7..336ca0b8524 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 22125e6f9ff..cd59f440334 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: -- 2.39.5