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.

diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el
index 2aade140e250159ce775c1cca073d772abb3d21b..eaf2532da39c0e9515e3dae0c044531e4d21fa72 100644 (file)
--- 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 90811199f2502551621703d98be72ba2f50d6ba9..cb8c59b05a2e529213d17f3083fec47c2f504757 100644 (file)
--- 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 f21624cfd87f58ee7a3765427873554a340cb73a..1185bee447ba7906958d3348f49d59247ee5164a 100644 (file)
--- 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)))))