master 21112e3683 1/5: Pretty print OClosure slot accessors

[Stefan Monnier]

branch: master
commit 21112e3683dd7c1f88028bac4b1835204b8e30f8
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>

    Pretty print OClosure slot accessors
    
    * lisp/emacs-lisp/oclosure.el (oclosure--accessor-cl-print): New function.
    * lisp/emacs-lisp/cl-print.el (cl-print-object) <accessor>: New method.
    * test/lisp/emacs-lisp/nadvice-tests.el (advice-test-call-interactively):
    Avoid `defun` within a function.
---
 lisp/emacs-lisp/cl-print.el           | 6 ++++++
 lisp/emacs-lisp/oclosure.el           | 7 +++++++
 test/lisp/emacs-lisp/nadvice-tests.el | 8 ++++----
 3 files changed, 17 insertions(+), 4 deletions(-)

diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el
index 2aade140e2..eaf2532da3 100644
--- a/lisp/emacs-lisp/cl-print.el
+++ b/lisp/emacs-lisp/cl-print.el
@@ -242,6 +242,12 @@ into a button whose action shows the function's 
disassembly.")
         (cl-print-object props stream)))
     (princ ")" stream)))
 
+;; This belongs in oclosure.el, of course, but some load-ordering issues make 
it
+;; complicated.
+(cl-defmethod cl-print-object ((object accessor) stream)
+  ;; FIXME: η-reduce!
+  (oclosure--accessor-cl-print object stream))
+
 (cl-defmethod cl-print-object ((object cl-structure-object) stream)
   (if (and cl-print--depth (natnump print-level)
            (> cl-print--depth print-level))
diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el
index 90811199f2..cb8c59b05a 100644
--- a/lisp/emacs-lisp/oclosure.el
+++ b/lisp/emacs-lisp/oclosure.el
@@ -505,6 +505,13 @@ This has 2 uses:
   "OClosure function to access a specific slot of an object."
   type slot)
 
+(defun oclosure--accessor-cl-print (object stream)
+  (princ "#f(accessor " stream)
+  (prin1 (accessor--type object) stream)
+  (princ "." stream)
+  (prin1 (accessor--slot object) stream)
+  (princ ")" stream))
+
 (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'.
diff --git a/test/lisp/emacs-lisp/nadvice-tests.el 
b/test/lisp/emacs-lisp/nadvice-tests.el
index f21624cfd8..1185bee447 100644
--- a/test/lisp/emacs-lisp/nadvice-tests.el
+++ b/test/lisp/emacs-lisp/nadvice-tests.el
@@ -153,13 +153,13 @@ function being an around advice."
 
 (ert-deftest advice-test-call-interactively ()
   "Check interaction between advice on call-interactively and 
called-interactively-p."
-  (defun sm-test7.4 () (interactive) (cons 1 (called-interactively-p)))
-  (let ((old (symbol-function 'call-interactively)))
+  (let ((sm-test7.4 (lambda () (interactive) (cons 1 
(called-interactively-p))))
+        (old (symbol-function 'call-interactively)))
     (unwind-protect
         (progn
           (advice-add 'call-interactively :before #'ignore)
-          (should (equal (sm-test7.4) '(1 . nil)))
-          (should (equal (call-interactively 'sm-test7.4) '(1 . t))))
+          (should (equal (funcall sm-test7.4) '(1 . nil)))
+          (should (equal (call-interactively sm-test7.4) '(1 . t))))
       (advice-remove 'call-interactively #'ignore)
       (should (eq (symbol-function 'call-interactively) old)))))