diff options
Diffstat (limited to 'lisp/emacs-lisp/cl-print.el')
| -rw-r--r-- | lisp/emacs-lisp/cl-print.el | 79 |
1 files changed, 59 insertions, 20 deletions
diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el index 8a8d4a4c1af..e9ca0412848 100644 --- a/lisp/emacs-lisp/cl-print.el +++ b/lisp/emacs-lisp/cl-print.el @@ -33,10 +33,13 @@ ;;; Code: +(require 'button) + (defvar cl-print-readably nil "If non-nil, try and make sure the result can be `read'.") (defvar cl-print--number-table nil) +(defvar cl-print--currently-printing nil) ;;;###autoload (cl-defgeneric cl-print-object (object stream) @@ -59,8 +62,9 @@ call other entry points instead, such as `cl-prin1'." (princ "(" stream) (cl-print-object car stream) (while (and (consp object) - (not (and cl-print--number-table - (numberp (gethash object cl-print--number-table))))) + (not (if cl-print--number-table + (numberp (gethash object cl-print--number-table)) + (memq object cl-print--currently-printing)))) (princ " " stream) (cl-print-object (pop object) stream)) (when object @@ -74,23 +78,38 @@ call other entry points instead, such as `cl-prin1'." (cl-print-object (aref object i) stream)) (princ "]" stream)) +(define-button-type 'help-byte-code + 'follow-link t + 'action (lambda (button) + (disassemble (button-get button 'byte-code-function))) + 'help-echo (purecopy "mouse-2, RET: disassemble this function")) + (defvar cl-print-compiled nil "Control how to print byte-compiled functions. Can be: - `static' to print the vector of constants. - `disassemble' to print the disassembly of the code. - nil to skip printing any details about the code.") +(defvar cl-print-compiled-button t + "Control how to print byte-compiled functions into buffers. +When the stream is a buffer, make the bytecode part of the output +into a button whose action shows the function's disassembly.") + +(autoload 'disassemble-1 "disass") + (cl-defmethod cl-print-object ((object compiled-function) stream) + (unless stream (setq stream standard-output)) ;; We use "#f(...)" rather than "#<...>" so that pp.el gives better results. (princ "#f(compiled-function " stream) (let ((args (help-function-arglist object 'preserve-names))) (if args (prin1 args stream) (princ "()" stream))) - (let ((doc (documentation object 'raw))) - (when doc - (princ " " stream) - (prin1 doc stream))) + (pcase (help-split-fundoc (documentation object 'raw) object) + ;; Drop args which `help-function-arglist' already printed. + (`(,_usage . ,(and doc (guard (stringp doc)))) + (princ " " stream) + (prin1 doc stream))) (let ((inter (interactive-form object))) (when inter (princ " " stream) @@ -108,10 +127,19 @@ call other entry points instead, such as `cl-prin1'." (disassemble-1 object 0) (buffer-string)) stream) - (princ " #<bytecode>" stream) - (when (eq cl-print-compiled 'static) - (princ " " stream) - (cl-print-object (aref object 2) stream))) + (princ " " stream) + (let ((button-start (and cl-print-compiled-button + (bufferp stream) + (with-current-buffer stream (point))))) + (princ "#<bytecode>" stream) + (when (eq cl-print-compiled 'static) + (princ " " stream) + (cl-print-object (aref object 2) stream)) + (when button-start + (with-current-buffer stream + (make-text-button button-start (point) + :type 'help-byte-code + 'byte-code-function object))))) (princ ")" stream)) ;; This belongs in nadvice.el, of course, but some load-ordering issues make it @@ -137,7 +165,7 @@ call other entry points instead, such as `cl-prin1'." (cl-defmethod cl-print-object ((object cl-structure-object) stream) (princ "#s(" stream) - (let* ((class (symbol-value (aref object 0))) + (let* ((class (cl-find-class (type-of object))) (slots (cl--struct-class-slots class))) (princ (cl--struct-class-name class) stream) (dotimes (i (length slots)) @@ -156,15 +184,26 @@ call other entry points instead, such as `cl-prin1'." (cl-defmethod cl-print-object :around (object stream) ;; FIXME: Only put such an :around method on types where it's relevant. - (let ((n (if cl-print--number-table (gethash object cl-print--number-table)))) - (if (not (numberp n)) - (cl-call-next-method) - (if (> n 0) - ;; Already printed. Just print a reference. - (progn (princ "#" stream) (princ n stream) (princ "#" stream)) - (puthash object (- n) cl-print--number-table) - (princ "#" stream) (princ (- n) stream) (princ "=" stream) - (cl-call-next-method))))) + (cond + (print-circle + (let ((n (gethash object cl-print--number-table))) + (if (not (numberp n)) + (cl-call-next-method) + (if (> n 0) + ;; Already printed. Just print a reference. + (progn (princ "#" stream) (princ n stream) (princ "#" stream)) + (puthash object (- n) cl-print--number-table) + (princ "#" stream) (princ (- n) stream) (princ "=" stream) + (cl-call-next-method))))) + ((let ((already-printing (memq object cl-print--currently-printing))) + (when already-printing + ;; Currently printing, just print reference to avoid endless + ;; recursion. + (princ "#" stream) + (princ (length (cdr already-printing)) stream)))) + (t (let ((cl-print--currently-printing + (cons object cl-print--currently-printing))) + (cl-call-next-method))))) (defvar cl-print--number-index nil) |