>From e5499ea5fdb3b4aad76b4d38f4d657b034778711 Mon Sep 17 00:00:00 2001
From: Noam Postavsky <npostavs@gmail.com>
Date: Sat, 11 Feb 2017 19:00:19 -0500
Subject: [PATCH v2 4/6] Hide byte code in backtraces (Bug#6991)

* lisp/emacs-lisp/cl-print.el: Autoload `disassemble-1'.
(cl-print-compiled-button): New variable.
(help-byte-code): New button type, calls `disassemble' in its action.
(cl-print-object): Use it if `cl-print-compiled-button' is
non-nil.
(debugger-insert-backtrace): Use `cl-print' with `cl-print-compiled-button'
let-bound to t.

* lisp/emacs-lisp/cl-print.el
---
 lisp/emacs-lisp/cl-print.el | 33 +++++++++++++++++++++++++++++----
 lisp/emacs-lisp/debug.el    | 11 ++++++++---
 2 files changed, 37 insertions(+), 7 deletions(-)

diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el
index 65c86d2b65..44c6a4312d 100644
--- a/lisp/emacs-lisp/cl-print.el
+++ b/lisp/emacs-lisp/cl-print.el
@@ -33,6 +33,8 @@
 
 ;;; Code:
 
+(require 'button)
+
 (defvar cl-print-readably nil
   "If non-nil, try and make sure the result can be `read'.")
 
@@ -74,13 +76,27 @@ (cl-defmethod cl-print-object ((object vector) stream)
     (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 nil
+  "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)))
@@ -108,10 +124,19 @@ (cl-defmethod cl-print-object ((object compiled-function) stream)
          (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
diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el
index effe7f0cb3..83c206e163 100644
--- a/lisp/emacs-lisp/debug.el
+++ b/lisp/emacs-lisp/debug.el
@@ -265,10 +265,15 @@ (defun debug (&rest args)
       debugger-value)))
 
 
+(defvar cl-print-compiled)
+(defvar cl-print-compiled-button)
+
 (defun debugger-insert-backtrace (frames do-xrefs)
   "Format and insert the backtrace FRAMES at point.
 Make functions into cross-reference buttons if DO-XREFS is non-nil."
   (let ((standard-output (current-buffer))
+        (cl-print-compiled nil)
+        (cl-print-compiled-button t)
         (eval-buffers eval-buffer-list))
     (require 'help-mode)     ; Define `help-function-def' button type.
     (pcase-dolist (`(,evald ,fun ,args ,flags) frames)
@@ -278,10 +283,10 @@ (defun debugger-insert-backtrace (frames do-xrefs)
             (fun-pt (point)))
         (cond
          ((and evald (not debugger-stack-frame-as-list))
-          (prin1 fun)
-          (if args (prin1 args) (princ "()")))
+          (cl-prin1 fun)
+          (if args (cl-prin1 args) (princ "()")))
          (t
-          (prin1 (cons fun args))
+          (cl-prin1 (cons fun args))
           (cl-incf fun-pt)))
         (when fun-file
           (make-text-button fun-pt (+ fun-pt (length (symbol-name fun)))
-- 
2.11.1