scratch/interpreted-function 256ea7509b8: -

[Stefan Monnier]

branch: scratch/interpreted-function
commit 256ea7509b8ba840cebe9537bb48afb1e22117cc
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>

    -
---
 lisp/descr-text.el | 18 ++++++------------
 lisp/help-fns.el   | 19 +++++++++++-------
 lisp/profiler.el   | 56 ++++++++++++++++++------------------------------------
 lisp/transient.el  |  6 +-----
 4 files changed, 37 insertions(+), 62 deletions(-)

diff --git a/lisp/descr-text.el b/lisp/descr-text.el
index eeab995c37d..d8ff5f3406c 100644
--- a/lisp/descr-text.el
+++ b/lisp/descr-text.el
@@ -44,22 +44,16 @@
 
 (defun describe-text-sexp (sexp)
   "Insert a short description of SEXP in the current buffer."
-  (let ((pp (condition-case signal
-               (pp-to-string sexp)
-             (error (prin1-to-string signal)))))
-    (when (string-match-p "\n\\'" pp)
-      (setq pp (substring pp 0 (1- (length pp)))))
-
-    (if (and (not (string-search "\n" pp))
-            (<= (length pp) (- (window-width) (current-column))))
-       (insert pp)
+  (let ((printed (format "%S" sexp)))
+    (if (and (not (string-search "\n" printed))
+        (<= (length printed) (- (window-width) (current-column))))
+       (insert printed)
       (insert-text-button
        "[Show]"
        'follow-link t
        'action (lambda (&rest _ignore)
-                 (with-output-to-temp-buffer
-                     "*Pp Eval Output*"
-                   (princ pp)))
+                 ;; FIXME: Why "eval output"?
+                 (pp-display-expression sexp "*Pp Eval Output*"))
        'help-echo "mouse-2, RET: pretty print value in another buffer"))))
 
 (defun describe-property-list (properties)
diff --git a/lisp/help-fns.el b/lisp/help-fns.el
index f14c65f766e..98c23f1dc55 100644
--- a/lisp/help-fns.el
+++ b/lisp/help-fns.el
@@ -2453,7 +2453,8 @@ one of them returns non-nil."
   (cond
    ((subr-primitive-p function)
     (describe-function function))
-   ((and (compiled-function-p function) (not (kmacro-p function)))
+   ((and (compiled-function-p function)
+         (not (and (fboundp 'kmacro-p) (kmacro-p function))))
     (disassemble function))
    (t
     ;; FIXME: Use cl-print!
@@ -2465,10 +2466,14 @@ one of them returns non-nil."
   ;; FIXME: For kmacros, should we print the key-sequence?
   (cond
    ((symbolp function)
-    (let ((name (let ((print-gensym t)) (prin1-to-string function))))
-      (make-text-button name nil
-                        'type 'help-function
-                        'help-args (list function))))
+    (let ((name (if (eq (intern-soft (symbol-name function)) function)
+                    (symbol-name function)
+                  (concat "#:" (symbol-name function)))))
+      (if (not (fboundp function))
+          name
+        (make-text-button name nil
+                          'type 'help-function
+                          'help-args (list function)))))
    ((gethash function help-fns--function-names))
    ((subrp function)
     (let ((name (subr-name function)))
@@ -2485,8 +2490,8 @@ one of them returns non-nil."
                     (if (consp function)
                         (car function) (cl-type-of function))))
           (hash (sxhash-eq function))
-          ;; Use 2 digits minimum.
-          (mask #xff)
+          ;; Use 3 digits minimum.
+          (mask #xfff)
           name)
       (while
           (let* ((hex (format (concat "%0"
diff --git a/lisp/profiler.el b/lisp/profiler.el
index 016e33fdc77..921d73c6660 100644
--- a/lisp/profiler.el
+++ b/lisp/profiler.el
@@ -91,7 +91,8 @@
           if (< width len)
            collect (progn (put-text-property (max 0 (- width 2)) len
                                              'invisible 'profiler str)
-                          str) into frags
+                          str)
+           into frags
           else
           collect
            (let ((padding (make-string (max 0 (- width len)) ?\s)))
@@ -100,33 +101,11 @@
               (right (concat padding str))))
           into frags
           finally return (apply #'concat frags)))
-
-
-;;; Entries
-
-(defun profiler-format-entry (entry)
-  "Format ENTRY in human readable string.
-ENTRY would be a function name of a function itself."
-  ;; FIXME: Use a `function-name' primitive?
-  (cond ((eq (car-safe entry) 'lambda)
-        (format "#<lambda %#x>" (sxhash entry)))
-       ((closurep entry)
-        (format "#<closure %#x>" (sxhash entry)))
-       ((or (subrp entry) (symbolp entry) (stringp entry))
-        (format "%s" entry))
-       (t
-        (format "#<unknown %#x>" (sxhash entry)))))
-
-(defun profiler-fixup-entry (entry)
-  (if (symbolp entry)
-      entry
-    (profiler-format-entry entry)))
-
 
 ;;; Backtraces
 
 (defun profiler-fixup-backtrace (backtrace)
-  (apply 'vector (mapcar 'profiler-fixup-entry backtrace)))
+  (apply #'vector (mapcar #'help-fns-function-name backtrace)))
 
 
 ;;; Logs
@@ -472,17 +451,15 @@ Do not touch this variable directly.")
   (let ((string (cond
                 ((eq entry t)
                  "Others")
-                ((and (symbolp entry)
-                      (fboundp entry))
-                 (propertize (symbol-name entry)
-                             'face 'link
-                              'follow-link "\r"
-                             'mouse-face 'highlight
-                             'help-echo "\
+                (t (propertize (help-fns-function-name entry)
+                               'keymap '(make-sparse-keymap)
+                               'follow-link "\r"
+                               ;; FIXME: The help-echo code gets confused
+                               ;; by the `follow-link' property and rewrites
+                               ;; `mouse-2' to `mouse-1' :-(
+                               'help-echo "\
 mouse-2: jump to definition\n\
-RET: expand or collapse"))
-                (t
-                 (profiler-format-entry entry)))))
+RET: expand or collapse")))))
     (propertize string 'profiler-entry entry)))
 
 (defun profiler-report-make-name-part (tree)
@@ -717,10 +694,13 @@ point."
         (current-buffer))
     (and event (setq event (event-end event))
          (posn-set-point event))
-    (let ((tree (profiler-report-calltree-at-point)))
-      (when tree
-        (let ((entry (profiler-calltree-entry tree)))
-          (find-function entry))))))
+    (save-excursion
+      (forward-line 0)
+      (let ((eol (pos-eol)))
+        (forward-button 1)
+        (if (> (point) eol)
+            (error "No entry found")
+          (push-button))))))
 
 (defun profiler-report-describe-entry ()
   "Describe entry at point."
diff --git a/lisp/transient.el b/lisp/transient.el
index 90c42e9784a..0cd34df06e6 100644
--- a/lisp/transient.el
+++ b/lisp/transient.el
@@ -2503,11 +2503,7 @@ value.  Otherwise return CHILDREN as is."
       (if (symbolp arg)
           (message "-- %-22s (cmd: %s, event: %S, exit: %s%s)"
                    arg
-                   (or (and (symbolp this-command) this-command)
-                       ;; FIXME: Use `function-name'?
-                       (if (byte-code-function-p this-command)
-                           "#[...]"
-                         this-command))
+                   (help-fns-function-name this-command)
                    (key-description (this-command-keys-vector))
                    transient--exitp
                    (cond ((stringp (car args))