From 21112e3683dd7c1f88028bac4b1835204b8e30f8 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Tue, 26 Apr 2022 17:30:29 -0400 Subject: [PATCH] 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) : 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 2aade140e25..eaf2532da39 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 90811199f25..cb8c59b05a2 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 f21624cfd87..1185bee447b 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))))) -- 2.39.5