Merge branch 'master' of git.sv.gnu.org:/srv/git/emacs

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)