From aa45ea8a33132f3a95b1e2c085776919febd5458 Mon Sep 17 00:00:00 2001
From: Alan Mackenzie <acm@muc.de>
Date: Wed, 11 Oct 2023 13:26:01 +0000
Subject: [PATCH] In cl-prin1, enable raw printing for a byte-compiled function

* lisp/emacs-lisp/cl-print.el (cl-print-compiled): document the
new option `raw'.
(cl-print-object/compiled-function): when cl-print-compiled is
`raw', just print the function using `prin1'.  Apply a button
to this output which, when activated disassembles the function.

* etc/NEWS (cl-print): Add an entry for this new feature.
---
 etc/NEWS                    |  4 ++
 lisp/emacs-lisp/cl-print.el | 83 +++++++++++++++++++++----------------
 2 files changed, 52 insertions(+), 35 deletions(-)

diff --git a/etc/NEWS b/etc/NEWS
index 220568429fd..6637a5c87e2 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -162,6 +162,10 @@ should now work anywhere the data is generated by 'cl-print'.
 
 *** Modes can control the expansion via 'cl-print-expand-ellipsis-function'.
 
+*** There is a new setting 'raw' for 'cl-print-compiled' which causes
+byte-compiled functions to be printed in full by 'prin1'.  A button on
+this output can be activated to disassemble the function.
+
 ** Modeline elements can now be right-aligned.
 Anything following the symbol 'mode-line-format-right-align' in
 'mode-line-format' will be right-aligned.  Exactly where it is
diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el
index b6d1f13bb2f..56e35078d39 100644
--- a/lisp/emacs-lisp/cl-print.el
+++ b/lisp/emacs-lisp/cl-print.el
@@ -165,6 +165,7 @@ Print the contents hidden by the ellipsis to STREAM."
 (defvar cl-print-compiled nil
   "Control how to print byte-compiled functions.
 Acceptable values include:
+- `raw' to print out the full contents of the function using `prin1'.
 - `static' to print the vector of constants.
 - `disassemble' to print the disassembly of the code.
 - nil to skip printing any details about the code.")
@@ -187,42 +188,54 @@ into a button whose action shows the function's disassembly.")
     (if args
         (prin1 args stream)
       (princ "()" 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)
-      (cl-print-object
-       (if (eq 'byte-code (car-safe (cadr inter)))
-           `(interactive ,(make-byte-code nil (nth 1 (cadr inter))
-                                          (nth 2 (cadr inter))
-                                          (nth 3 (cadr inter))))
-         inter)
-       stream)))
-  (if (eq cl-print-compiled 'disassemble)
-      (princ
-       (with-temp-buffer
-         (insert "\n")
-         (disassemble-1 object 0)
-         (buffer-string))
-       stream)
-    (princ " " stream)
-    (let ((button-start (and cl-print-compiled-button
-                             (bufferp stream)
-                             (with-current-buffer stream (point)))))
-      (princ (format "#<bytecode %#x>" (sxhash object)) stream)
-      (when (eq cl-print-compiled 'static)
+  (if (eq cl-print-compiled 'raw)
+      (let ((button-start
+             (and cl-print-compiled-button
+                  (bufferp stream)
+                  (with-current-buffer stream (1+ (point))))))
+        (princ " " stream)
+        (prin1 object stream)
+        (when button-start
+          (with-current-buffer stream
+            (make-text-button button-start (point)
+                              :type 'help-byte-code
+                              'byte-code-function object))))
+    (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)
-        (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))
+        (cl-print-object
+         (if (eq 'byte-code (car-safe (cadr inter)))
+             `(interactive ,(make-byte-code nil (nth 1 (cadr inter))
+                                            (nth 2 (cadr inter))
+                                            (nth 3 (cadr inter))))
+           inter)
+         stream)))
+    (if (eq cl-print-compiled 'disassemble)
+        (princ
+         (with-temp-buffer
+           (insert "\n")
+           (disassemble-1 object 0)
+           (buffer-string))
+         stream)
+      (princ " " stream)
+      (let ((button-start (and cl-print-compiled-button
+                               (bufferp stream)
+                               (with-current-buffer stream (point)))))
+        (princ (format "#<bytecode %#x>" (sxhash object)) 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 oclosure.el, of course, but some load-ordering issues make it
 ;; complicated.
-- 
2.39.5