/usr/share/emacs/site-lisp/slime/contrib/slime-typeout-frame.el is in slime 2:2.10.1-3.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 | (require 'slime)
(require 'slime-autodoc)
(require 'cl-lib)
(defvar slime-typeout-frame-unbind-stack ())
(define-slime-contrib slime-typeout-frame
"Display messages in a dedicated frame."
(:authors "Luke Gorrie <luke@synap.se>")
(:license "GPL")
(:on-load
(unless (slime-typeout-tty-only-p)
(add-hook 'slime-connected-hook 'slime-ensure-typeout-frame)
(cl-loop for (var value) in
'((slime-message-function slime-typeout-message)
(slime-background-message-function slime-typeout-message)
(slime-autodoc-message-function slime-typeout-autodoc-message)
(slime-autodoc-dimensions-function
slime-typeout-autodoc-dimensions))
do (slime-typeout-frame-init-var var value))))
(:on-unload
(remove-hook 'slime-connected-hook 'slime-ensure-typeout-frame)
(cl-loop for (var value) in slime-typeout-frame-unbind-stack
do (cond ((eq var 'slime-unbound) (makunbound var))
(t (set var value))))
(setq slime-typeout-frame-unbind-stack nil)))
(defun slime-typeout-frame-init-var (var value)
(push (list var (if (boundp var) (symbol-value var) 'slime-unbound))
slime-typeout-frame-unbind-stack)
(set var value))
(defun slime-typeout-tty-only-p ()
(cond ((featurep 'xemacs)
(null (remove 'tty (mapcar #'device-type (console-device-list)))))
(t (not (window-system)))))
;;;; Typeout frame
;; When a "typeout frame" exists it is used to display certain
;; messages instead of the echo area or pop-up windows.
(defvar slime-typeout-window nil
"The current typeout window.")
(defvar slime-typeout-frame-properties
'((height . 10) (minibuffer . nil))
"The typeout frame properties (passed to `make-frame').")
(defun slime-typeout-buffer ()
(with-current-buffer (get-buffer-create (slime-buffer-name :typeout))
(setq buffer-read-only t)
(current-buffer)))
(defun slime-typeout-active-p ()
(and slime-typeout-window
(window-live-p slime-typeout-window)))
(defun slime-typeout-message-aux (format-string &rest format-args)
(slime-ensure-typeout-frame)
(with-current-buffer (slime-typeout-buffer)
(let ((inhibit-read-only t)
(msg (apply #'format format-string format-args)))
(unless (string= msg "")
(erase-buffer)
(insert msg)))))
(defun slime-typeout-message (format-string &rest format-args)
(apply #'slime-typeout-message-aux format-string format-args))
(defun slime-make-typeout-frame ()
"Create a frame for displaying messages (e.g. arglists)."
(interactive)
(let ((frame (make-frame slime-typeout-frame-properties)))
(save-selected-window
(select-window (frame-selected-window frame))
(switch-to-buffer (slime-typeout-buffer))
(setq slime-typeout-window (selected-window)))))
(defun slime-ensure-typeout-frame ()
"Create the typeout frame unless it already exists."
(interactive)
(if (slime-typeout-active-p)
(save-selected-window
(select-window slime-typeout-window)
(switch-to-buffer (slime-typeout-buffer)))
(slime-make-typeout-frame)))
(defun slime-typeout-autodoc-message (doc)
;; No need for refreshing per `slime-autodoc-pre-command-refresh-echo-area'.
;; FIXME: eldoc doesn't know anything about this
(slime-typeout-message-aux "%s" doc))
(defun slime-typeout-autodoc-dimensions ()
(cond ((slime-typeout-active-p)
(list (window-width slime-typeout-window) nil))
(t
(list 75 nil))))
(provide 'slime-typeout-frame)
|