Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Move swank payloads to lein-swank plugin.

  • Loading branch information...
commit 634b76e50ed56bec0072491384c4ef0a1e99a85a 1 parent 1dd73d6
@technomancy authored
View
1  .gitignore
@@ -5,3 +5,4 @@ multi-lib/
pom.xml
.lein-failures
.lein-deps-sum
+/lein-swank/.lein-plugins/checksum
View
4 lein-swank/resources/swank_elisp_payloads.clj
@@ -0,0 +1,4 @@
+["swank/payload/slime.el"
+ "swank/payload/slime-repl.el"
+ "swank/payload/slime-frame-colors.el"
+ "swank/payload/slime-eldoc.el"]
View
37 lein-swank/src/swank/payload/slime-compile-presave.el
@@ -0,0 +1,37 @@
+;;; slime-compile-presave.el --- Refuse to save non-compiling Slime buffers
+
+;; Copyright © 2011 Phil Hagelberg
+;;
+;; Authors: Phil Hagelberg <technomancy@gmail.com>
+;; URL: http://github.com/technomancy/swank-clojure
+;; Version: 1.0.0
+;; Keywords: languages, lisp
+
+;; This file is not part of GNU Emacs.
+
+;;; Code:
+
+(defvar slime-compile-presave? nil
+ "Refuse to save slime-enabled buffers if they don't compile.")
+
+;;;###autoload
+(defun slime-compile-presave-toggle ()
+ (interactive)
+ (message "slime-compile-presave %s."
+ (if (setq slime-compile-presave? (not slime-compile-presave?))
+ "enabled" "disabled")))
+
+;;;###autoload
+(defun slime-compile-presave-enable ()
+ (make-local-variable 'before-save-hook)
+ (add-hook 'before-save-hook (defun slime-compile-presave ()
+ (when slime-compile-presave?
+ (slime-eval `(swank:eval-and-grab-output
+ ,(buffer-substring-no-properties
+ (point-min) (point-max))))))))
+
+;;;###autoload
+(add-hook 'slime-mode-hook 'slime-compile-presave-enable)
+
+(provide 'slime-compile-presave)
+;;; slime-compile-presave.el ends here
View
12 lein-swank/src/swank/payload/slime-eldoc.el
@@ -0,0 +1,12 @@
+(require 'eldoc)
+(defun clojure-slime-eldoc-message ()
+ (when (and (featurep 'slime)
+ (slime-background-activities-enabled-p))
+ (slime-echo-arglist) ; async, return nil for now
+ nil))
+
+(defun clojure-localize-documentation-function ()
+ (set (make-local-variable 'eldoc-documentation-function)
+ 'clojure-slime-eldoc-message))
+
+(add-hook 'slime-mode-hook 'clojure-localize-documentation-function)
View
18 lein-swank/src/swank/payload/slime-frame-colors.el
@@ -0,0 +1,18 @@
+(require 'ansi-color)
+
+(defadvice sldb-insert-frame (around colorize-clj-trace (frame &optional face))
+ (progn
+ (ad-set-arg 0 (list (sldb-frame.number frame)
+ (ansi-color-apply (sldb-frame.string frame))
+ (sldb-frame.plist frame)))
+ ad-do-it
+ (save-excursion
+ (forward-line -1)
+ (skip-chars-forward "0-9 :")
+ (let ((beg-line (point)))
+ (end-of-line)
+ (remove-text-properties beg-line (point) '(face nil))))))
+
+(ad-activate #'sldb-insert-frame)
+
+(provide 'slime-frame-colors)
View
1,854 lein-swank/src/swank/payload/slime-repl.el
@@ -0,0 +1,1854 @@
+;;; slime-repl.el --- Read-Eval-Print Loop written in Emacs Lisp
+;;
+;; Original Author: Helmut Eller
+;; Contributors: to many to mention
+;; License: GNU GPL (same license as Emacs)
+;; URL: http://common-lisp.net/project/slime/
+;; Version: 20091016
+;; Keywords: languages, lisp, slime
+;; Package-Requires: ((slime "20091016"))
+;; Adapted-by: Phil Hagelberg
+;;
+;;; Description:
+;;
+;; This file implements a Lisp Listener along with some niceties like
+;; a persistent history and various "shortcut" commands. Nothing here
+;; depends on comint.el; I/O is multiplexed over SLIME's socket.
+;;
+;; This used to be the default REPL for SLIME, but it was hard to
+;; maintain.
+;;
+;;; Installation:
+;;
+;; Call slime-setup and include 'slime-repl as argument:
+;;
+;; (slime-setup '(slime-repl [others conribs ...]))
+;;
+
+;;;;; slime-repl
+
+(defgroup slime-repl nil
+ "The Read-Eval-Print Loop (*slime-repl* buffer)."
+ :prefix "slime-repl-"
+ :group 'slime)
+
+(defcustom slime-repl-shortcut-dispatch-char ?\,
+ "Character used to distinguish repl commands from lisp forms."
+ :type '(character)
+ :group 'slime-repl)
+
+(defcustom slime-repl-only-save-lisp-buffers t
+ "When T we only attempt to save lisp-mode file buffers. When
+ NIL slime will attempt to save all buffers (as per
+ save-some-buffers). This applies to all ASDF related repl
+ shortcuts."
+ :type '(boolean)
+ :group 'slime-repl)
+
+(defface slime-repl-prompt-face
+ (if (slime-face-inheritance-possible-p)
+ '((t (:inherit font-lock-keyword-face)))
+ '((((class color) (background light)) (:foreground "Purple"))
+ (((class color) (background dark)) (:foreground "Cyan"))
+ (t (:weight bold))))
+ "Face for the prompt in the SLIME REPL."
+ :group 'slime-repl)
+
+(defface slime-repl-output-face
+ (if (slime-face-inheritance-possible-p)
+ '((t (:inherit font-lock-string-face)))
+ '((((class color) (background light)) (:foreground "RosyBrown"))
+ (((class color) (background dark)) (:foreground "LightSalmon"))
+ (t (:slant italic))))
+ "Face for Lisp output in the SLIME REPL."
+ :group 'slime-repl)
+
+(defface slime-repl-input-face
+ '((t (:bold t)))
+ "Face for previous input in the SLIME REPL."
+ :group 'slime-repl)
+
+(defface slime-repl-result-face
+ '((t ()))
+ "Face for the result of an evaluation in the SLIME REPL."
+ :group 'slime-repl)
+
+(defcustom slime-repl-history-file "~/.slime-history.eld"
+ "File to save the persistent REPL history to."
+ :type 'string
+ :group 'slime-repl)
+
+(defcustom slime-repl-history-size 200
+ "*Maximum number of lines for persistent REPL history."
+ :type 'integer
+ :group 'slime-repl)
+
+(defcustom slime-repl-history-file-coding-system
+ (cond ((slime-find-coding-system 'utf-8-unix) 'utf-8-unix)
+ (t slime-net-coding-system))
+ "*The coding system for the history file."
+ :type 'symbol
+ :group 'slime-repl)
+
+
+;; dummy defvar for compiler
+(defvar slime-repl-read-mode)
+
+(defun slime-reading-p ()
+ "True if Lisp is currently reading input from the REPL."
+ (with-current-buffer (slime-output-buffer)
+ slime-repl-read-mode))
+
+
+;;;; Stream output
+
+(slime-def-connection-var slime-connection-output-buffer nil
+ "The buffer for the REPL. May be nil or a dead buffer.")
+
+(make-variable-buffer-local
+ (defvar slime-output-start nil
+ "Marker for the start of the output for the evaluation."))
+
+(make-variable-buffer-local
+ (defvar slime-output-end nil
+ "Marker for end of output. New output is inserted at this mark."))
+
+;; dummy definitions for the compiler
+(defvar slime-repl-package-stack)
+(defvar slime-repl-directory-stack)
+(defvar slime-repl-input-start-mark)
+(defvar slime-repl-prompt-start-mark)
+
+(defun slime-output-buffer (&optional noprompt)
+ "Return the output buffer, create it if necessary."
+ (let ((buffer (slime-connection-output-buffer)))
+ (or (if (buffer-live-p buffer) buffer)
+ (setf (slime-connection-output-buffer)
+ (let ((connection (slime-connection)))
+ (with-current-buffer (slime-repl-buffer t connection)
+ (unless (eq major-mode 'slime-repl-mode)
+ (slime-repl-mode))
+ (setq slime-buffer-connection connection)
+ (setq slime-buffer-package (slime-lisp-package connection))
+ (slime-reset-repl-markers)
+ (unless noprompt
+ (slime-repl-insert-prompt))
+ (current-buffer)))))))
+
+(defvar slime-repl-banner-function 'slime-repl-insert-banner)
+
+(defun slime-repl-update-banner ()
+ (funcall slime-repl-banner-function)
+ (goto-char (point-max))
+ (slime-mark-output-start)
+ (slime-mark-input-start)
+ (slime-repl-insert-prompt))
+
+(defun slime-repl-insert-banner ()
+ (when (zerop (buffer-size))
+ (let ((welcome (concat "; SLIME " (or (slime-changelog-date)
+ "- ChangeLog file not found"))))
+ (insert welcome))))
+
+(defun slime-init-output-buffer (connection)
+ (with-current-buffer (slime-output-buffer t)
+ (setq slime-buffer-connection connection
+ slime-repl-directory-stack '()
+ slime-repl-package-stack '())
+ (slime-repl-update-banner)))
+
+(defun slime-display-output-buffer ()
+ "Display the output buffer and scroll to bottom."
+ (with-current-buffer (slime-output-buffer)
+ (goto-char (point-max))
+ (unless (get-buffer-window (current-buffer) t)
+ (display-buffer (current-buffer) t))
+ (slime-repl-show-maximum-output)))
+
+(defmacro slime-with-output-end-mark (&rest body)
+ "Execute BODY at `slime-output-end'.
+
+If point is initially at `slime-output-end' and the buffer is visible
+update window-point afterwards. If point is initially not at
+`slime-output-end, execute body inside a `save-excursion' block."
+ `(let ((body.. (lambda () ,@body))
+ (updatep.. (and (eobp) (pos-visible-in-window-p))))
+ (cond ((= (point) slime-output-end)
+ (let ((start.. (point)))
+ (funcall body..)
+ (set-marker slime-output-end (point))
+ (when (= start.. slime-repl-input-start-mark)
+ (set-marker slime-repl-input-start-mark (point)))))
+ (t
+ (save-excursion
+ (goto-char slime-output-end)
+ (funcall body..))))
+ (when updatep..
+ (slime-repl-show-maximum-output))))
+
+(defun slime-output-filter (process string)
+ (with-current-buffer (process-buffer process)
+ (when (and (plusp (length string))
+ (eq (process-status slime-buffer-connection) 'open))
+ (slime-write-string string))))
+
+(defvar slime-open-stream-hooks)
+
+(defun slime-open-stream-to-lisp (port)
+ (let ((stream (open-network-stream "*lisp-output-stream*"
+ (slime-with-connection-buffer ()
+ (current-buffer))
+ slime-lisp-host port)))
+ (slime-set-query-on-exit-flag stream)
+ (set-process-filter stream 'slime-output-filter)
+ (let ((pcs (process-coding-system (slime-current-connection))))
+ (set-process-coding-system stream (car pcs) (cdr pcs)))
+ (when-let (secret (slime-secret))
+ (slime-net-send secret stream))
+ (run-hook-with-args 'slime-open-stream-hooks stream)
+ stream))
+
+(defun slime-io-speed-test (&optional profile)
+ "A simple minded benchmark for stream performance.
+If a prefix argument is given, instrument the slime package for
+profiling before running the benchmark."
+ (interactive "P")
+ (eval-and-compile
+ (require 'elp))
+ (elp-reset-all)
+ (elp-restore-all)
+ (load "slime.el")
+ ;;(byte-compile-file "slime-net.el" t)
+ ;;(setq slime-log-events nil)
+ (setq slime-enable-evaluate-in-emacs t)
+ ;;(setq slime-repl-enable-presentations nil)
+ (when profile
+ (elp-instrument-package "slime-"))
+ (kill-buffer (slime-output-buffer))
+ (switch-to-buffer (slime-output-buffer))
+ (delete-other-windows)
+ (sit-for 0)
+ (slime-repl-send-string "(swank:io-speed-test 4000 1)")
+ (let ((proc (slime-inferior-process)))
+ (when proc
+ (display-buffer (process-buffer proc) t)
+ (goto-char (point-max)))))
+
+(defvar slime-write-string-function 'slime-repl-write-string)
+
+(defun slime-write-string (string &optional target)
+ "Insert STRING in the REPL buffer or some other TARGET.
+If TARGET is nil, insert STRING as regular process
+output. If TARGET is :repl-result, insert STRING as the result of the
+evaluation. Other values of TARGET map to an Emacs marker via the
+hashtable `slime-output-target-to-marker'; output is inserted at this marker."
+ (funcall slime-write-string-function string target))
+
+(defun slime-repl-write-string (string &optional target)
+ (case target
+ ((nil) (slime-repl-emit string))
+ (:repl-result (slime-repl-emit-result string))
+ (t (slime-emit-string string target))))
+
+(defvar slime-repl-popup-on-output nil
+ "Display the output buffer when some output is written.
+This is set to nil after displaying the buffer.")
+
+(defmacro slime-save-marker (marker &rest body)
+ (let ((pos (gensym "pos")))
+ `(let ((,pos (marker-position ,marker)))
+ (prog1 (progn . ,body)
+ (set-marker ,marker ,pos)))))
+
+(put 'slime-save-marker 'lisp-indent-function 1)
+
+(defun slime-repl-emit (string)
+ ;; insert the string STRING in the output buffer
+ (with-current-buffer (slime-output-buffer)
+ (save-excursion
+ (goto-char slime-output-end)
+ (slime-save-marker slime-output-start
+ (slime-propertize-region '(face slime-repl-output-face
+ rear-nonsticky (face))
+ (insert-before-markers string)
+ (when (and (= (point) slime-repl-prompt-start-mark)
+ (not (bolp)))
+ (insert-before-markers "\n")
+ (set-marker slime-output-end (1- (point)))))))
+ (when slime-repl-popup-on-output
+ (setq slime-repl-popup-on-output nil)
+ (display-buffer (current-buffer)))
+ (slime-repl-show-maximum-output)))
+
+(defun slime-repl-emit-result (string &optional bol)
+ ;; insert STRING and mark it as evaluation result
+ (with-current-buffer (slime-output-buffer)
+ (save-excursion
+ (slime-save-marker slime-output-start
+ (slime-save-marker slime-output-end
+ (goto-char slime-repl-input-start-mark)
+ (when (and bol (not (bolp))) (insert-before-markers "\n"))
+ (slime-propertize-region `(face slime-repl-result-face
+ rear-nonsticky (face))
+ (insert-before-markers string)))))
+ (slime-repl-show-maximum-output)))
+
+(defvar slime-last-output-target-id 0
+ "The last integer we used as a TARGET id.")
+
+(defvar slime-output-target-to-marker
+ (make-hash-table)
+ "Map from TARGET ids to Emacs markers.
+The markers indicate where output should be inserted.")
+
+(defun slime-output-target-marker (target)
+ "Return the marker where output for TARGET should be inserted."
+ (case target
+ ((nil)
+ (with-current-buffer (slime-output-buffer)
+ slime-output-end))
+ (:repl-result
+ (with-current-buffer (slime-output-buffer)
+ slime-repl-input-start-mark))
+ (t
+ (gethash target slime-output-target-to-marker))))
+
+(defun slime-emit-string (string target)
+ "Insert STRING at target TARGET.
+See `slime-output-target-to-marker'."
+ (let* ((marker (slime-output-target-marker target))
+ (buffer (and marker (marker-buffer marker))))
+ (when buffer
+ (with-current-buffer buffer
+ (save-excursion
+ ;; Insert STRING at MARKER, then move MARKER behind
+ ;; the insertion.
+ (goto-char marker)
+ (insert-before-markers string)
+ (set-marker marker (point)))))))
+
+(defun slime-switch-to-output-buffer ()
+ "Select the output buffer, when possible in an existing window.
+
+Hint: You can use `display-buffer-reuse-frames' and
+`special-display-buffer-names' to customize the frame in which
+the buffer should appear."
+ (interactive)
+ (slime-pop-to-buffer (slime-output-buffer))
+ (goto-char (point-max)))
+
+
+;;;; REPL
+;;
+;; The REPL uses some markers to separate input from output. The
+;; usual configuration is as follows:
+;;
+;; ... output ... ... result ... prompt> ... input ...
+;; ^ ^ ^ ^ ^
+;; output-start output-end prompt-start input-start point-max
+;;
+;; input-start is a right inserting marker, because
+;; we want it to stay behind when the user inserts text.
+;;
+;; We maintain the following invariant:
+;;
+;; output-start <= output-end <= input-start.
+;;
+;; This invariant is important, because we must be prepared for
+;; asynchronous output and asynchronous reads. ("Asynchronous" means,
+;; triggered by Lisp and not by Emacs.)
+;;
+;; All output is inserted at the output-end marker. Some care must be
+;; taken when output-end and input-start are at the same position: if
+;; we insert at that point, we must move the right markers. We should
+;; also not leave (window-)point in the middle of the new output. The
+;; idiom we use is a combination to slime-save-marker,
+;; insert-before-markers, and manually updating window-point
+;; afterwards.
+;;
+;; A "synchronous" evaluation request proceeds as follows: the user
+;; inserts some text between input-start and point-max and then hits
+;; return. We send that region to Lisp, move the output and input
+;; makers to the line after the input and wait. When we receive the
+;; result, we insert it together with a prompt between the output-end
+;; and input-start mark. See `slime-repl-insert-prompt'.
+;;
+;; It is possible that some output for such an evaluation request
+;; arrives after the result. This output is inserted before the
+;; result (and before the prompt).
+;;
+;; If we are in "reading" state, e.g., during a call to Y-OR-N-P,
+;; there is no prompt between output-end and input-start.
+;;
+
+;; FIXME: slime-lisp-package should be local in a REPL buffer
+(slime-def-connection-var slime-lisp-package
+ "COMMON-LISP-USER"
+ "The current package name of the Superior lisp.
+This is automatically synchronized from Lisp.")
+
+(slime-def-connection-var slime-lisp-package-prompt-string
+ "CL-USER"
+ "The current package name of the Superior lisp.
+This is automatically synchronized from Lisp.")
+
+(slime-make-variables-buffer-local
+ (defvar slime-repl-package-stack nil
+ "The stack of packages visited in this repl.")
+
+ (defvar slime-repl-directory-stack nil
+ "The stack of default directories associated with this repl.")
+
+ (defvar slime-repl-prompt-start-mark)
+ (defvar slime-repl-input-start-mark)
+ (defvar slime-repl-old-input-counter 0
+ "Counter used to generate unique `slime-repl-old-input' properties.
+This property value must be unique to avoid having adjacent inputs be
+joined together."))
+
+(defun slime-reset-repl-markers ()
+ (dolist (markname '(slime-output-start
+ slime-output-end
+ slime-repl-prompt-start-mark
+ slime-repl-input-start-mark))
+ (set markname (make-marker))
+ (set-marker (symbol-value markname) (point))))
+
+;;;;; REPL mode setup
+
+(defvar slime-repl-mode-map)
+
+(let ((map (copy-keymap slime-parent-map)))
+ (set-keymap-parent map lisp-mode-map)
+ (setq slime-repl-mode-map (make-sparse-keymap))
+ (set-keymap-parent slime-repl-mode-map map)
+ (loop for (key command) in slime-editing-keys
+ do (define-key slime-repl-mode-map key command)))
+
+(slime-define-keys slime-prefix-map
+ ("\C-z" 'slime-switch-to-output-buffer)
+ ("\M-p" 'slime-repl-set-package))
+
+(slime-define-keys slime-mode-map
+ ("\C-c~" 'slime-sync-package-and-default-directory)
+ ("\C-c\C-y" 'slime-call-defun))
+
+(slime-define-keys slime-connection-list-mode-map
+ ((kbd "RET") 'slime-goto-connection)
+ ([return] 'slime-goto-connection))
+
+(slime-define-keys slime-repl-mode-map
+ ("\C-m" 'slime-repl-return)
+ ([return] 'slime-repl-return)
+ ("\C-j" 'slime-repl-newline-and-indent)
+ ("\C-\M-m" 'slime-repl-closing-return)
+ ([(control return)] 'slime-repl-closing-return)
+ ("\C-a" 'slime-repl-bol)
+ ([home] 'slime-repl-bol)
+ ("\M-p" 'slime-repl-previous-input)
+ ((kbd "C-<up>") 'slime-repl-backward-input)
+ ("\M-n" 'slime-repl-next-input)
+ ((kbd "C-<down>") 'slime-repl-forward-input)
+ ("\M-r" 'slime-repl-previous-matching-input)
+ ("\M-s" 'slime-repl-next-matching-input)
+ ("\C-c\C-c" 'slime-interrupt)
+ ;("\t" 'slime-complete-symbol)
+ ("\t" 'slime-indent-and-complete-symbol)
+ ("\M-\t" 'slime-complete-symbol)
+ (" " 'slime-space)
+ ("\C-c\C-o" 'slime-repl-clear-output)
+ ("\C-c\M-o" 'slime-repl-clear-buffer)
+ ("\C-c\C-u" 'slime-repl-kill-input)
+ ("\C-c\C-n" 'slime-repl-next-prompt)
+ ("\C-c\C-p" 'slime-repl-previous-prompt)
+ ("\C-c\C-z" 'slime-nop))
+
+(slime-define-keys slime-inspector-mode-map
+ ((kbd "M-RET") 'slime-inspector-copy-down-to-repl))
+
+(def-slime-selector-method ?r
+ "SLIME Read-Eval-Print-Loop."
+ (slime-output-buffer))
+
+(defun slime-repl-mode ()
+ "Major mode for interacting with a superior Lisp.
+\\{slime-repl-mode-map}"
+ (interactive)
+ (kill-all-local-variables)
+ (setq major-mode 'slime-repl-mode)
+ (use-local-map slime-repl-mode-map)
+ (lisp-mode-variables t)
+ (set (make-local-variable 'lisp-indent-function)
+ 'common-lisp-indent-function)
+ (setq font-lock-defaults nil)
+ (setq mode-name "REPL")
+ (setq slime-current-thread :repl-thread)
+ (set (make-local-variable 'scroll-conservatively) 20)
+ (set (make-local-variable 'scroll-margin) 0)
+ (when slime-repl-history-file
+ (slime-repl-safe-load-history)
+ (slime-add-local-hook 'kill-buffer-hook
+ 'slime-repl-safe-save-merged-history))
+ (add-hook 'kill-emacs-hook 'slime-repl-save-all-histories)
+ (slime-setup-command-hooks)
+ ;; At the REPL, we define beginning-of-defun and end-of-defun to be
+ ;; the start of the previous prompt or next prompt respectively.
+ ;; Notice the interplay with SLIME-REPL-BEGINNING-OF-DEFUN.
+ (set (make-local-variable 'beginning-of-defun-function)
+ 'slime-repl-mode-beginning-of-defun)
+ (set (make-local-variable 'end-of-defun-function)
+ 'slime-repl-mode-end-of-defun)
+ (slime-run-mode-hooks 'slime-repl-mode-hook))
+
+(defun slime-repl-buffer (&optional create connection)
+ "Get the REPL buffer for the current connection; optionally create."
+ (funcall (if create #'get-buffer-create #'get-buffer)
+ (format "*slime-repl %s*" (slime-connection-name connection))))
+
+(defun slime-repl ()
+ (interactive)
+ (slime-switch-to-output-buffer))
+
+(defun slime-repl-mode-beginning-of-defun ()
+ (slime-repl-previous-prompt)
+ t)
+
+(defun slime-repl-mode-end-of-defun ()
+ (slime-repl-next-prompt)
+ t)
+
+(defun slime-repl-send-string (string &optional command-string)
+ (cond (slime-repl-read-mode
+ (slime-repl-return-string string))
+ (t (slime-repl-eval-string string))))
+
+(defun slime-repl-eval-string (string)
+ (slime-rex ()
+ ((list 'swank:listener-eval string) (slime-lisp-package))
+ ((:ok result)
+ (slime-repl-insert-result result))
+ ((:abort)
+ (slime-repl-show-abort))))
+
+(defun slime-repl-insert-result (result)
+ (with-current-buffer (slime-output-buffer)
+ (save-excursion
+ (when result
+ (destructure-case result
+ ((:values &rest strings)
+ (cond ((null strings)
+ (slime-repl-emit-result "; No value\n" t))
+ (t
+ (dolist (s strings)
+ (slime-repl-emit-result s t)))))))
+ (slime-repl-insert-prompt))
+ (slime-repl-show-maximum-output)))
+
+(defun slime-repl-show-abort ()
+ (with-current-buffer (slime-output-buffer)
+ (save-excursion
+ (slime-save-marker slime-output-start
+ (slime-save-marker slime-output-end
+ (goto-char slime-output-end)
+ (insert-before-markers "; Evaluation aborted.\n")
+ (slime-repl-insert-prompt))))
+ (slime-repl-show-maximum-output)))
+
+(defun slime-repl-insert-prompt ()
+ "Insert the prompt (before markers!).
+Set point after the prompt.
+Return the position of the prompt beginning."
+ (goto-char slime-repl-input-start-mark)
+ (slime-save-marker slime-output-start
+ (slime-save-marker slime-output-end
+ (unless (bolp) (insert-before-markers "\n"))
+ (let ((prompt-start (point))
+ (prompt (format "%s> " (slime-lisp-package-prompt-string))))
+ (slime-propertize-region
+ '(face slime-repl-prompt-face read-only t intangible t
+ slime-repl-prompt t
+ ;; emacs stuff
+ rear-nonsticky (slime-repl-prompt read-only face intangible)
+ ;; xemacs stuff
+ start-open t end-open t)
+ (insert-before-markers prompt))
+ (set-marker slime-repl-prompt-start-mark prompt-start)
+ prompt-start))))
+
+(defun slime-repl-show-maximum-output ()
+ "Put the end of the buffer at the bottom of the window."
+ (when (eobp)
+ (let ((win (get-buffer-window (current-buffer))))
+ (when win
+ (with-selected-window win
+ (set-window-point win (point-max))
+ (recenter -1))))))
+
+(defvar slime-repl-current-input-hooks)
+
+(defun slime-repl-current-input (&optional until-point-p)
+ "Return the current input as string.
+The input is the region from after the last prompt to the end of
+buffer."
+ (or (run-hook-with-args-until-success 'slime-repl-current-input-hooks
+ until-point-p)
+ (buffer-substring-no-properties slime-repl-input-start-mark
+ (if until-point-p
+ (point)
+ (point-max)))))
+
+(defun slime-property-position (text-property &optional object)
+ "Return the first position of TEXT-PROPERTY, or nil."
+ (if (get-text-property 0 text-property object)
+ 0
+ (next-single-property-change 0 text-property object)))
+
+(defun slime-mark-input-start ()
+ (set-marker slime-repl-input-start-mark (point) (current-buffer)))
+
+(defun slime-mark-output-start ()
+ (set-marker slime-output-start (point))
+ (set-marker slime-output-end (point)))
+
+(defun slime-mark-output-end ()
+ ;; Don't put slime-repl-output-face again; it would remove the
+ ;; special presentation face, for instance in the SBCL inspector.
+ (add-text-properties slime-output-start slime-output-end
+ '(;;face slime-repl-output-face
+ rear-nonsticky (face))))
+
+(defun slime-repl-bol ()
+ "Go to the beginning of line or the prompt."
+ (interactive)
+ (cond ((and (>= (point) slime-repl-input-start-mark)
+ (slime-same-line-p (point) slime-repl-input-start-mark))
+ (goto-char slime-repl-input-start-mark))
+ (t (beginning-of-line 1)))
+ (slime-preserve-zmacs-region))
+
+(defun slime-preserve-zmacs-region ()
+ "In XEmacs, ensure that the zmacs-region stays active after this command."
+ (when (boundp 'zmacs-region-stays)
+ (set 'zmacs-region-stays t)))
+
+(defun slime-repl-in-input-area-p ()
+ (<= slime-repl-input-start-mark (point)))
+
+(defun slime-repl-at-prompt-start-p ()
+ ;; This will not work on non-current prompts.
+ (= (point) slime-repl-input-start-mark))
+
+(defun slime-repl-beginning-of-defun ()
+ "Move to beginning of defun."
+ (interactive)
+ ;; We call BEGINNING-OF-DEFUN if we're at the start of a prompt
+ ;; already, to trigger SLIME-REPL-MODE-BEGINNING-OF-DEFUN by means
+ ;; of the locally bound BEGINNING-OF-DEFUN-FUNCTION, in order to
+ ;; jump to the start of the previous prompt.
+ (if (and (not (slime-repl-at-prompt-start-p))
+ (slime-repl-in-input-area-p))
+ (goto-char slime-repl-input-start-mark)
+ (beginning-of-defun))
+ t)
+
+;; FIXME: this looks very strange
+(defun slime-repl-end-of-defun ()
+ "Move to next of defun."
+ (interactive)
+ ;; C.f. SLIME-REPL-BEGINNING-OF-DEFUN.
+ (if (and (not (= (point) (point-max)))
+ (slime-repl-in-input-area-p))
+ (goto-char (point-max))
+ (end-of-defun))
+ t)
+
+(defun slime-repl-previous-prompt ()
+ "Move backward to the previous prompt."
+ (interactive)
+ (slime-repl-find-prompt t))
+
+(defun slime-repl-next-prompt ()
+ "Move forward to the next prompt."
+ (interactive)
+ (slime-repl-find-prompt))
+
+(defun slime-repl-find-prompt (&optional backward)
+ (let ((origin (point))
+ (prop 'slime-repl-prompt))
+ (while (progn
+ (slime-search-property-change prop backward)
+ (not (or (slime-end-of-proprange-p prop) (bobp) (eobp)))))
+ (unless (slime-end-of-proprange-p prop)
+ (goto-char origin))))
+
+(defun slime-search-property-change (prop &optional backward)
+ (cond (backward
+ (goto-char (previous-single-char-property-change (point) prop)))
+ (t
+ (goto-char (next-single-char-property-change (point) prop)))))
+
+(defun slime-end-of-proprange-p (property)
+ (and (get-char-property (max 1 (1- (point))) property)
+ (not (get-char-property (point) property))))
+
+(defvar slime-repl-return-hooks)
+
+(defun slime-repl-return (&optional end-of-input)
+ "Evaluate the current input string, or insert a newline.
+Send the current input ony if a whole expression has been entered,
+i.e. the parenthesis are matched.
+
+With prefix argument send the input even if the parenthesis are not
+balanced."
+ (interactive "P")
+ (slime-check-connected)
+ (cond (end-of-input
+ (slime-repl-send-input))
+ (slime-repl-read-mode ; bad style?
+ (slime-repl-send-input t))
+ ((and (get-text-property (point) 'slime-repl-old-input)
+ (< (point) slime-repl-input-start-mark))
+ (slime-repl-grab-old-input end-of-input)
+ (slime-repl-recenter-if-needed))
+ ((run-hook-with-args-until-success 'slime-repl-return-hooks))
+ ((slime-input-complete-p slime-repl-input-start-mark (point-max))
+ (slime-repl-send-input t))
+ (t
+ (slime-repl-newline-and-indent)
+ (message "[input not complete]"))))
+
+(defun slime-repl-recenter-if-needed ()
+ "Make sure that (point) is visible."
+ (unless (pos-visible-in-window-p (point-max))
+ (save-excursion
+ (goto-char (point-max))
+ (recenter -1))))
+
+(defun slime-repl-send-input (&optional newline)
+ "Goto to the end of the input and send the current input.
+If NEWLINE is true then add a newline at the end of the input."
+ (unless (slime-repl-in-input-area-p)
+ (error "No input at point."))
+ (goto-char (point-max))
+ (let ((end (point))) ; end of input, without the newline
+ (slime-repl-add-to-input-history
+ (buffer-substring slime-repl-input-start-mark end))
+ (when newline
+ (insert "\n")
+ (slime-repl-show-maximum-output))
+ (let ((inhibit-modification-hooks t))
+ (add-text-properties slime-repl-input-start-mark
+ (point)
+ `(slime-repl-old-input
+ ,(incf slime-repl-old-input-counter))))
+ (let ((overlay (make-overlay slime-repl-input-start-mark end)))
+ ;; These properties are on an overlay so that they won't be taken
+ ;; by kill/yank.
+ (overlay-put overlay 'read-only t)
+ (overlay-put overlay 'face 'slime-repl-input-face)))
+ (let ((input (slime-repl-current-input)))
+ (goto-char (point-max))
+ (slime-mark-input-start)
+ (slime-mark-output-start)
+ (slime-repl-send-string input)))
+
+(defun slime-repl-grab-old-input (replace)
+ "Resend the old REPL input at point.
+If replace is non-nil the current input is replaced with the old
+input; otherwise the new input is appended. The old input has the
+text property `slime-repl-old-input'."
+ (multiple-value-bind (beg end) (slime-property-bounds 'slime-repl-old-input)
+ (let ((old-input (buffer-substring beg end)) ;;preserve
+ ;;properties, they will be removed later
+ (offset (- (point) beg)))
+ ;; Append the old input or replace the current input
+ (cond (replace (goto-char slime-repl-input-start-mark))
+ (t (goto-char (point-max))
+ (unless (eq (char-before) ?\ )
+ (insert " "))))
+ (delete-region (point) (point-max))
+ (save-excursion
+ (insert old-input)
+ (when (equal (char-before) ?\n)
+ (delete-char -1)))
+ (forward-char offset))))
+
+(defun slime-repl-closing-return ()
+ "Evaluate the current input string after closing all open lists."
+ (interactive)
+ (goto-char (point-max))
+ (save-restriction
+ (narrow-to-region slime-repl-input-start-mark (point))
+ (while (ignore-errors (save-excursion (backward-up-list 1)) t)
+ (insert ")")))
+ (slime-repl-return))
+
+(defun slime-repl-newline-and-indent ()
+ "Insert a newline, then indent the next line.
+Restrict the buffer from the prompt for indentation, to avoid being
+confused by strange characters (like unmatched quotes) appearing
+earlier in the buffer."
+ (interactive)
+ (save-restriction
+ (narrow-to-region slime-repl-prompt-start-mark (point-max))
+ (insert "\n")
+ (lisp-indent-line)))
+
+(defun slime-repl-delete-current-input ()
+ "Delete all text from the prompt."
+ (interactive)
+ (delete-region slime-repl-input-start-mark (point-max)))
+
+(defun slime-repl-kill-input ()
+ "Kill all text from the prompt to point."
+ (interactive)
+ (cond ((< (marker-position slime-repl-input-start-mark) (point))
+ (kill-region slime-repl-input-start-mark (point)))
+ ((= (point) (marker-position slime-repl-input-start-mark))
+ (slime-repl-delete-current-input))))
+
+(defun slime-repl-replace-input (string)
+ (slime-repl-delete-current-input)
+ (insert-and-inherit string))
+
+(defun slime-repl-input-line-beginning-position ()
+ (save-excursion
+ (goto-char slime-repl-input-start-mark)
+ (line-beginning-position)))
+
+(defvar slime-repl-clear-buffer-hook)
+
+(defun slime-repl-clear-buffer ()
+ "Delete the output generated by the Lisp process."
+ (interactive)
+ (let ((inhibit-read-only t))
+ (delete-region (point-min) slime-repl-prompt-start-mark)
+ (delete-region slime-output-start slime-output-end)
+ (when (< (point) slime-repl-input-start-mark)
+ (goto-char slime-repl-input-start-mark))
+ (recenter t))
+ (run-hooks 'slime-repl-clear-buffer-hook))
+
+(defun slime-repl-clear-output ()
+ "Delete the output inserted since the last input."
+ (interactive)
+ (let ((start (save-excursion
+ (slime-repl-previous-prompt)
+ (ignore-errors (forward-sexp))
+ (forward-line)
+ (point)))
+ (end (1- (slime-repl-input-line-beginning-position))))
+ (when (< start end)
+ (let ((inhibit-read-only t))
+ (delete-region start end)
+ (save-excursion
+ (goto-char start)
+ (insert ";;; output flushed"))))))
+
+(defun slime-repl-set-package (package)
+ "Set the package of the REPL buffer to PACKAGE."
+ (interactive (list (let* ((p (slime-current-package))
+ (p (and p (slime-pretty-package-name p)))
+ (p (and (not (equal p (slime-lisp-package))) p)))
+ (slime-read-package-name "Package: " p))))
+ (with-current-buffer (slime-output-buffer)
+ (let ((previouse-point (- (point) slime-repl-input-start-mark)))
+ (destructuring-bind (name prompt-string)
+ (slime-repl-shortcut-eval `(swank:set-package ,package))
+ (setf (slime-lisp-package) name)
+ (setf (slime-lisp-package-prompt-string) prompt-string)
+ (setf slime-buffer-package name)
+ (slime-repl-insert-prompt)
+ (when (plusp previouse-point)
+ (goto-char (+ previouse-point slime-repl-input-start-mark)))))))
+
+
+;;;;; History
+
+(defcustom slime-repl-wrap-history nil
+ "*T to wrap history around when the end is reached."
+ :type 'boolean
+ :group 'slime-repl)
+
+(make-variable-buffer-local
+ (defvar slime-repl-input-history '()
+ "History list of strings read from the REPL buffer."))
+
+(defun slime-repl-add-to-input-history (string)
+ "Add STRING to the input history.
+Empty strings and duplicates are ignored."
+ (unless (or (equal string "")
+ (equal string (car slime-repl-input-history)))
+ (push string slime-repl-input-history)))
+
+;; These two vars contain the state of the last history search. We
+;; only use them if `last-command' was 'slime-repl-history-replace,
+;; otherwise we reinitialize them.
+
+(defvar slime-repl-input-history-position -1
+ "Newer items have smaller indices.")
+
+(defvar slime-repl-history-pattern nil
+ "The regexp most recently used for finding input history.")
+
+(defun slime-repl-history-replace (direction &optional regexp)
+ "Replace the current input with the next line in DIRECTION.
+DIRECTION is 'forward' or 'backward' (in the history list).
+If REGEXP is non-nil, only lines matching REGEXP are considered."
+ (setq slime-repl-history-pattern regexp)
+ (let* ((min-pos -1)
+ (max-pos (length slime-repl-input-history))
+ (pos0 (cond ((slime-repl-history-search-in-progress-p)
+ slime-repl-input-history-position)
+ (t min-pos)))
+ (pos (slime-repl-position-in-history pos0 direction (or regexp "")))
+ (msg nil))
+ (cond ((and (< min-pos pos) (< pos max-pos))
+ (slime-repl-replace-input (nth pos slime-repl-input-history))
+ (setq msg (format "History item: %d" pos)))
+ ((not slime-repl-wrap-history)
+ (setq msg (cond ((= pos min-pos) "End of history")
+ ((= pos max-pos) "Beginning of history"))))
+ (slime-repl-wrap-history
+ (setq pos (if (= pos min-pos) max-pos min-pos))
+ (setq msg "Wrapped history")))
+ (when (or (<= pos min-pos) (<= max-pos pos))
+ (when regexp
+ (setq msg (concat msg "; no matching item"))))
+ ;;(message "%s [%d %d %s]" msg start-pos pos regexp)
+ (message "%s%s" msg (cond ((not regexp) "")
+ (t (format "; current regexp: %s" regexp))))
+ (setq slime-repl-input-history-position pos)
+ (setq this-command 'slime-repl-history-replace)))
+
+(defun slime-repl-history-search-in-progress-p ()
+ (eq last-command 'slime-repl-history-replace))
+
+(defun slime-repl-terminate-history-search ()
+ (setq last-command this-command))
+
+(defun slime-repl-position-in-history (start-pos direction regexp)
+ "Return the position of the history item matching regexp.
+Return -1 resp. the length of the history if no item matches"
+ ;; Loop through the history list looking for a matching line
+ (let* ((step (ecase direction
+ (forward -1)
+ (backward 1)))
+ (history slime-repl-input-history)
+ (len (length history)))
+ (loop for pos = (+ start-pos step) then (+ pos step)
+ if (< pos 0) return -1
+ if (<= len pos) return len
+ if (string-match regexp (nth pos history)) return pos)))
+
+(defun slime-repl-previous-input ()
+ "Cycle backwards through input history.
+If the `last-command' was a history navigation command use the
+same search pattern for this command.
+Otherwise use the current input as search pattern."
+ (interactive)
+ (slime-repl-history-replace 'backward (slime-repl-history-pattern t)))
+
+(defun slime-repl-next-input ()
+ "Cycle forwards through input history.
+See `slime-repl-previous-input'."
+ (interactive)
+ (slime-repl-history-replace 'forward (slime-repl-history-pattern t)))
+
+(defun slime-repl-forward-input ()
+ "Cycle forwards through input history."
+ (interactive)
+ (slime-repl-history-replace 'forward (slime-repl-history-pattern)))
+
+(defun slime-repl-backward-input ()
+ "Cycle backwards through input history."
+ (interactive)
+ (slime-repl-history-replace 'backward (slime-repl-history-pattern)))
+
+(defun slime-repl-previous-matching-input (regexp)
+ (interactive "sPrevious element matching (regexp): ")
+ (slime-repl-terminate-history-search)
+ (slime-repl-history-replace 'backward regexp))
+
+(defun slime-repl-next-matching-input (regexp)
+ (interactive "sNext element matching (regexp): ")
+ (slime-repl-terminate-history-search)
+ (slime-repl-history-replace 'forward regexp))
+
+(defun slime-repl-history-pattern (&optional use-current-input)
+ "Return the regexp for the navigation commands."
+ (cond ((slime-repl-history-search-in-progress-p)
+ slime-repl-history-pattern)
+ (use-current-input
+ (assert (<= slime-repl-input-start-mark (point)))
+ (let ((str (slime-repl-current-input t)))
+ (cond ((string-match "^[ \n]*$" str) nil)
+ (t (concat "^" (regexp-quote str))))))
+ (t nil)))
+
+(defun slime-repl-delete-from-input-history (string)
+ "Delete STRING from the repl input history.
+
+When string is not provided then clear the current repl input and
+use it as an input. This is useful to get rid of unwanted repl
+history entries while navigating the repl history."
+ (interactive (list (slime-repl-current-input)))
+ (let ((merged-history
+ (slime-repl-merge-histories slime-repl-input-history
+ (slime-repl-read-history nil t))))
+ (setq slime-repl-input-history
+ (delete* string merged-history :test #'string=))
+ (slime-repl-save-history))
+ (slime-repl-delete-current-input))
+
+;;;;; Persistent History
+
+(defun slime-repl-merge-histories (old-hist new-hist)
+ "Merge entries from OLD-HIST and NEW-HIST."
+ ;; Newer items in each list are at the beginning.
+ (let* ((ht (make-hash-table :test #'equal))
+ (test (lambda (entry)
+ (or (gethash entry ht)
+ (progn (setf (gethash entry ht) t)
+ nil)))))
+ (append (remove-if test new-hist)
+ (remove-if test old-hist))))
+
+(defun slime-repl-load-history (&optional filename)
+ "Set the current SLIME REPL history.
+It can be read either from FILENAME or `slime-repl-history-file' or
+from a user defined filename."
+ (interactive (list (slime-repl-read-history-filename)))
+ (let ((file (or filename slime-repl-history-file)))
+ (setq slime-repl-input-history (slime-repl-read-history file t))))
+
+(defun slime-repl-read-history (&optional filename noerrer)
+ "Read and return the history from FILENAME.
+The default value for FILENAME is `slime-repl-history-file'.
+If NOERROR is true return and the file doesn't exits return nil."
+ (let ((file (or filename slime-repl-history-file)))
+ (cond ((not (file-readable-p file)) '())
+ (t (with-temp-buffer
+ (insert-file-contents file)
+ (read (current-buffer)))))))
+
+(defun slime-repl-read-history-filename ()
+ (read-file-name "Use SLIME REPL history from file: "
+ slime-repl-history-file))
+
+(defun slime-repl-save-merged-history (&optional filename)
+ "Read the history file, merge the current REPL history and save it.
+This tries to be smart in merging the history from the file and the
+current history in that it tries to detect the unique entries using
+`slime-repl-merge-histories'."
+ (interactive (list (slime-repl-read-history-filename)))
+ (let ((file (or filename slime-repl-history-file)))
+ (with-temp-message "saving history..."
+ (let ((hist (slime-repl-merge-histories (slime-repl-read-history file t)
+ slime-repl-input-history)))
+ (slime-repl-save-history file hist)))))
+
+(defun slime-repl-save-history (&optional filename history)
+ "Simply save the current SLIME REPL history to a file.
+When SLIME is setup to always load the old history and one uses only
+one instance of slime all the time, there is no need to merge the
+files and this function is sufficient.
+
+When the list is longer than `slime-repl-history-size' it will be
+truncated. That part is untested, though!"
+ (interactive (list (slime-repl-read-history-filename)))
+ (let ((file (or filename slime-repl-history-file))
+ (hist (or history slime-repl-input-history)))
+ (unless (file-writable-p file)
+ (error (format "History file not writable: %s" file)))
+ (let ((hist (subseq hist 0 (min (length hist) slime-repl-history-size))))
+ ;;(message "saving %s to %s\n" hist file)
+ (with-temp-file file
+ (let ((cs slime-repl-history-file-coding-system)
+ (print-length nil) (print-level nil))
+ (setq buffer-file-coding-system cs)
+ (insert (format ";; -*- coding: %s -*-\n" cs))
+ (insert ";; History for SLIME REPL. Automatically written.\n"
+ ";; Edit only if you know what you're doing\n")
+ (prin1 (mapcar #'substring-no-properties hist) (current-buffer)))))))
+
+(defun slime-repl-save-all-histories ()
+ "Save the history in each repl buffer."
+ (dolist (b (buffer-list))
+ (with-current-buffer b
+ (when (eq major-mode 'slime-repl-mode)
+ (slime-repl-safe-save-merged-history)))))
+
+(defun slime-repl-safe-save-merged-history ()
+ (slime-repl-call-with-handler
+ #'slime-repl-save-merged-history
+ "%S while saving the history. Continue? "))
+
+(defun slime-repl-safe-load-history ()
+ (slime-repl-call-with-handler
+ #'slime-repl-load-history
+ "%S while loading the history. Continue? "))
+
+(defun slime-repl-call-with-handler (fun query)
+ "Call FUN in the context of an error handler.
+The handler will use qeuery to ask the use if the error should be ingored."
+ (condition-case err
+ (funcall fun)
+ (error
+ (if (y-or-n-p (format query (error-message-string err)))
+ nil
+ (signal (car err) (cdr err))))))
+
+
+;;;;; REPL Read Mode
+
+(define-key slime-repl-mode-map
+ (string slime-repl-shortcut-dispatch-char) 'slime-handle-repl-shortcut)
+
+(define-minor-mode slime-repl-read-mode
+ "Mode the read input from Emacs
+\\{slime-repl-read-mode-map}"
+ nil
+ "[read]"
+ '(("\C-m" . slime-repl-return)
+ ([return] . slime-repl-return)
+ ("\C-c\C-b" . slime-repl-read-break)
+ ("\C-c\C-c" . slime-repl-read-break)))
+
+(make-variable-buffer-local
+ (defvar slime-read-string-threads nil))
+
+(make-variable-buffer-local
+ (defvar slime-read-string-tags nil))
+
+(defun slime-repl-read-string (thread tag)
+ (slime-switch-to-output-buffer)
+ (push thread slime-read-string-threads)
+ (push tag slime-read-string-tags)
+ (goto-char (point-max))
+ (slime-mark-output-end)
+ (slime-mark-input-start)
+ (slime-repl-read-mode 1))
+
+(defun slime-repl-return-string (string)
+ (slime-dispatch-event `(:emacs-return-string
+ ,(pop slime-read-string-threads)
+ ,(pop slime-read-string-tags)
+ ,string))
+ (slime-repl-read-mode -1))
+
+(defun slime-repl-read-break ()
+ (interactive)
+ (slime-dispatch-event `(:emacs-interrupt ,(car slime-read-string-threads))))
+
+(defun slime-repl-abort-read (thread tag)
+ (with-current-buffer (slime-output-buffer)
+ (pop slime-read-string-threads)
+ (pop slime-read-string-tags)
+ (slime-repl-read-mode -1)
+ (message "Read aborted")))
+
+
+;;;;; REPL handlers
+
+(defstruct (slime-repl-shortcut (:conc-name slime-repl-shortcut.))
+ symbol names handler one-liner)
+
+(defvar slime-repl-shortcut-table nil
+ "A list of slime-repl-shortcuts")
+
+(defvar slime-repl-shortcut-history '()
+ "History list of shortcut command names.")
+
+(defvar slime-within-repl-shortcut-handler-p nil
+ "Bound to T if we're in a REPL shortcut handler invoked from the REPL.")
+
+(defun slime-handle-repl-shortcut ()
+ (interactive)
+ (if (> (point) slime-repl-input-start-mark)
+ (insert (string slime-repl-shortcut-dispatch-char))
+ (let ((shortcut (slime-lookup-shortcut
+ (completing-read "Command: "
+ (slime-bogus-completion-alist
+ (slime-list-all-repl-shortcuts))
+ nil t nil
+ 'slime-repl-shortcut-history))))
+ (with-struct (slime-repl-shortcut. handler) shortcut
+ (let ((slime-within-repl-shortcut-handler-p t))
+ (call-interactively handler))))))
+
+(defun slime-list-all-repl-shortcuts ()
+ (loop for shortcut in slime-repl-shortcut-table
+ append (slime-repl-shortcut.names shortcut)))
+
+(defun slime-lookup-shortcut (name)
+ (find-if (lambda (s) (member name (slime-repl-shortcut.names s)))
+ slime-repl-shortcut-table))
+
+(defmacro defslime-repl-shortcut (elisp-name names &rest options)
+ "Define a new repl shortcut. ELISP-NAME is a symbol specifying
+the name of the interactive function to create, or NIL if no
+function should be created.
+
+NAMES is a list of \(full-name . aliases\).
+
+OPTIONS is an plist specifying the handler doing the actual work
+of the shortcut \(`:handler'\), and a help text \(`:one-liner'\)."
+ `(progn
+ ,(when elisp-name
+ `(defun ,elisp-name ()
+ (interactive)
+ (call-interactively ,(second (assoc :handler options)))))
+ (let ((new-shortcut (make-slime-repl-shortcut
+ :symbol ',elisp-name
+ :names (list ,@names)
+ ,@(apply #'append options))))
+ (setq slime-repl-shortcut-table
+ (remove-if (lambda (s)
+ (member ',(car names) (slime-repl-shortcut.names s)))
+ slime-repl-shortcut-table))
+ (push new-shortcut slime-repl-shortcut-table)
+ ',elisp-name)))
+
+(defun slime-repl-shortcut-eval (sexp &optional package)
+ "This function should be used by REPL shortcut handlers instead
+of `slime-eval' to evaluate their final expansion. (This
+expansion will be added to the REPL's history.)"
+ (when slime-within-repl-shortcut-handler-p ; were we invoked via ,foo?
+ (slime-repl-add-to-input-history (prin1-to-string sexp)))
+ (slime-eval sexp package))
+
+(defun slime-repl-shortcut-eval-async (sexp &optional cont package)
+ "This function should be used by REPL shortcut handlers instead
+of `slime-eval-async' to evaluate their final expansion. (This
+expansion will be added to the REPL's history.)"
+ (when slime-within-repl-shortcut-handler-p ; were we invoked via ,foo?
+ (slime-repl-add-to-input-history (prin1-to-string sexp)))
+ (slime-eval-async sexp cont package))
+
+
+(defun slime-list-repl-short-cuts ()
+ (interactive)
+ (slime-with-popup-buffer ("*slime-repl-help*")
+ (let ((table (sort* (copy-list slime-repl-shortcut-table) #'string<
+ :key (lambda (x)
+ (car (slime-repl-shortcut.names x))))))
+ (dolist (shortcut table)
+ (let ((names (slime-repl-shortcut.names shortcut)))
+ (insert (pop names)) ;; first print the "full" name
+ (when names
+ ;; we also have aliases
+ (insert " (aka ")
+ (while (cdr names)
+ (insert (pop names) ", "))
+ (insert (car names) ")"))
+ (insert "\n " (slime-repl-shortcut.one-liner shortcut)
+ "\n"))))))
+
+(defun slime-save-some-lisp-buffers ()
+ (if slime-repl-only-save-lisp-buffers
+ (save-some-buffers nil (lambda ()
+ (and (memq major-mode slime-lisp-modes)
+ (not (null buffer-file-name)))))
+ (save-some-buffers)))
+
+
+(defslime-repl-shortcut slime-repl-shortcut-help ("help" "?")
+ (:handler 'slime-list-repl-short-cuts)
+ (:one-liner "Display the help."))
+
+(defslime-repl-shortcut nil ("change-directory" "!d" "cd")
+ (:handler 'slime-set-default-directory)
+ (:one-liner "Change the current directory."))
+
+(defslime-repl-shortcut nil ("pwd")
+ (:handler (lambda ()
+ (interactive)
+ (let ((dir (slime-eval `(swank:default-directory))))
+ (message "Directory %s" dir))))
+ (:one-liner "Show the current directory."))
+
+(defslime-repl-shortcut slime-repl-push-directory
+ ("push-directory" "+d" "pushd")
+ (:handler (lambda (directory)
+ (interactive
+ (list (read-directory-name
+ "Push directory: "
+ (slime-eval '(swank:default-directory))
+ nil nil "")))
+ (push (slime-eval '(swank:default-directory))
+ slime-repl-directory-stack)
+ (slime-set-default-directory directory)))
+ (:one-liner "Save the current directory and set it to a new one."))
+
+(defslime-repl-shortcut slime-repl-pop-directory
+ ("pop-directory" "-d" "popd")
+ (:handler (lambda ()
+ (interactive)
+ (if (null slime-repl-directory-stack)
+ (message "Directory stack is empty.")
+ (slime-set-default-directory
+ (pop slime-repl-directory-stack)))))
+ (:one-liner "Restore the last saved directory."))
+
+(defslime-repl-shortcut nil ("change-package" "!p" "in-package" "in")
+ (:handler 'slime-repl-set-package)
+ (:one-liner "Change the current package."))
+
+(defslime-repl-shortcut slime-repl-push-package ("push-package" "+p")
+ (:handler (lambda (package)
+ (interactive (list (slime-read-package-name "Package: ")))
+ (push (slime-lisp-package) slime-repl-package-stack)
+ (slime-repl-set-package package)))
+ (:one-liner "Save the current package and set it to a new one."))
+
+(defslime-repl-shortcut slime-repl-pop-package ("pop-package" "-p")
+ (:handler (lambda ()
+ (interactive)
+ (if (null slime-repl-package-stack)
+ (message "Package stack is empty.")
+ (slime-repl-set-package
+ (pop slime-repl-package-stack)))))
+ (:one-liner "Restore the last saved package."))
+
+(defslime-repl-shortcut slime-repl-resend ("resend-form")
+ (:handler (lambda ()
+ (interactive)
+ (insert (car slime-repl-input-history))
+ (insert "\n")
+ (slime-repl-send-input)))
+ (:one-liner "Resend the last form."))
+
+(defslime-repl-shortcut slime-repl-disconnect ("disconnect")
+ (:handler 'slime-disconnect)
+ (:one-liner "Disconnect the current connection."))
+
+(defslime-repl-shortcut slime-repl-disconnect-all ("disconnect-all")
+ (:handler 'slime-disconnect-all)
+ (:one-liner "Disconnect all connections."))
+
+(defslime-repl-shortcut slime-repl-sayoonara ("sayoonara")
+ (:handler (lambda ()
+ (interactive)
+ (when (slime-connected-p)
+ (slime-quit-lisp))
+ (slime-kill-all-buffers)))
+ (:one-liner "Quit all Lisps and close all SLIME buffers."))
+
+(defslime-repl-shortcut slime-repl-quit ("quit")
+ (:handler (lambda ()
+ (interactive)
+ ;; `slime-quit-lisp' determines the connection to quit
+ ;; on behalf of the REPL's `slime-buffer-connection'.
+ (let ((repl-buffer (slime-output-buffer)))
+ (slime-quit-lisp)
+ (kill-buffer repl-buffer))))
+ (:one-liner "Quit the current Lisp."))
+
+(defslime-repl-shortcut slime-repl-defparameter ("defparameter" "!")
+ (:handler (lambda (name value)
+ (interactive (list (slime-read-symbol-name "Name (symbol): " t)
+ (slime-read-from-minibuffer "Value: " "*")))
+ (insert "(cl:defparameter " name " " value
+ " \"REPL generated global variable.\")")
+ (slime-repl-send-input t)))
+ (:one-liner "Define a new global, special, variable."))
+
+(defslime-repl-shortcut slime-repl-compile-and-load ("compile-and-load" "cl")
+ (:handler (lambda (filename)
+ (interactive (list (expand-file-name
+ (read-file-name "File: " nil nil nil nil))))
+ (slime-save-some-lisp-buffers)
+ (slime-repl-shortcut-eval-async
+ `(swank:compile-file-if-needed
+ ,(slime-to-lisp-filename filename) t)
+ #'slime-compilation-finished)))
+ (:one-liner "Compile (if neccessary) and load a lisp file."))
+
+(defslime-repl-shortcut nil ("restart-inferior-lisp")
+ (:handler 'slime-restart-inferior-lisp)
+ (:one-liner "Restart *inferior-lisp* and reconnect SLIME."))
+
+(defun slime-redirect-inferior-output (&optional noerror)
+ "Redirect output of the inferior-process to the REPL buffer."
+ (interactive)
+ (let ((proc (slime-inferior-process)))
+ (cond (proc
+ (let ((filter (slime-rcurry #'slime-inferior-output-filter
+ (slime-current-connection))))
+ (set-process-filter proc filter)))
+ (noerror)
+ (t (error "No inferior lisp process")))))
+
+(defun slime-inferior-output-filter (proc string conn)
+ (cond ((eq (process-status conn) 'closed)
+ (message "Connection closed. Removing inferior output filter.")
+ (message "Lost output: %S" string)
+ (set-process-filter proc nil))
+ (t
+ (slime-output-filter conn string))))
+
+(defun slime-redirect-trace-output ()
+ "Redirect the trace output to a separate Emacs buffer."
+ (interactive)
+ (let ((buffer (get-buffer-create "*SLIME Trace Output*")))
+ (with-current-buffer buffer
+ (let ((marker (copy-marker (buffer-size)))
+ (target (incf slime-last-output-target-id)))
+ (puthash target marker slime-output-target-to-marker)
+ (slime-eval `(swank:redirect-trace-output ,target))))
+ ;; Note: We would like the entries in
+ ;; slime-output-target-to-marker to disappear when the buffers are
+ ;; killed. We cannot just make the hash-table ":weakness 'value"
+ ;; -- there is no reference from the buffers to the markers in the
+ ;; buffer, so entries would disappear even though the buffers are
+ ;; alive. Best solution might be to make buffer-local variables
+ ;; that keep the markers. --mkoeppe
+ (pop-to-buffer buffer)))
+
+(defun slime-call-defun ()
+ "Insert a call to the toplevel form defined around point into the REPL."
+ (interactive)
+ (flet ((insert-call (symbol)
+ (let* ((qualified-symbol-name (slime-qualify-cl-symbol-name symbol))
+ (symbol-name (slime-cl-symbol-name qualified-symbol-name))
+ (symbol-package (slime-cl-symbol-package qualified-symbol-name))
+ (function-call
+ (format "(%s " (if (equalp (slime-lisp-package) symbol-package)
+ symbol-name
+ qualified-symbol-name))))
+ (slime-switch-to-output-buffer)
+ (goto-char slime-repl-input-start-mark)
+ (insert function-call)
+ (save-excursion (insert ")")))))
+ (let ((toplevel (slime-parse-toplevel-form)))
+ (if (symbolp toplevel)
+ (error "Not in a function definition")
+ (destructure-case toplevel
+ (((:defun :defgeneric :defmacro :define-compiler-macro) symbol)
+ (insert-call symbol))
+ ((:defmethod symbol &rest args)
+ (declare (ignore args))
+ (insert-call symbol))
+ (t
+ (error "Not in a function definition")))))))
+
+(defun slime-inspector-copy-down-to-repl (number)
+ "Evaluate the inspector slot at point via the REPL (to set `*')."
+ (interactive (list (or (get-text-property (point) 'slime-part-number)
+ (error "No part at point"))))
+ (slime-repl-send-string (format "%s" `(swank:inspector-nth-part ,number)))
+ (slime-repl))
+
+
+(defun slime-set-default-directory (directory)
+ "Make DIRECTORY become Lisp's current directory."
+ (interactive (list (read-directory-name "Directory: " nil nil t)))
+ (let ((dir (expand-file-name directory)))
+ (message "default-directory: %s"
+ (slime-from-lisp-filename
+ (slime-repl-shortcut-eval `(swank:set-default-directory
+ ,(slime-to-lisp-filename dir)))))
+ (with-current-buffer (slime-output-buffer)
+ (setq default-directory dir))))
+
+(defun slime-sync-package-and-default-directory ()
+ "Set Lisp's package and directory to the values in current buffer."
+ (interactive)
+ (let* ((package (slime-current-package))
+ (exists-p (or (null package)
+ (slime-eval `(cl:packagep (swank::guess-package ,package)))))
+ (directory default-directory))
+ (when (and package exists-p)
+ (slime-repl-set-package package))
+ (slime-set-default-directory directory)
+ ;; Sync *inferior-lisp* dir
+ (let* ((proc (slime-process))
+ (buffer (and proc (process-buffer proc))))
+ (when buffer
+ (with-current-buffer buffer
+ (setq default-directory directory))))
+ (message "package: %s%s directory: %s"
+ (with-current-buffer (slime-output-buffer)
+ (slime-lisp-package))
+ (if exists-p "" (format " (package %s doesn't exist)" package))
+ directory)))
+
+(defun slime-goto-connection ()
+ "Switch to the REPL buffer for the connection at point."
+ (interactive)
+ (let ((slime-dispatching-connection (slime-connection-at-point)))
+ (switch-to-buffer (slime-output-buffer))))
+
+(defvar slime-repl-easy-menu
+ (let ((C '(slime-connected-p)))
+ `("REPL"
+ [ "Send Input" slime-repl-return ,C ]
+ [ "Close and Send Input " slime-repl-closing-return ,C ]
+ [ "Interrupt Lisp process" slime-interrupt ,C ]
+ "--"
+ [ "Previous Input" slime-repl-previous-input t ]
+ [ "Next Input" slime-repl-next-input t ]
+ [ "Goto Previous Prompt " slime-repl-previous-prompt t ]
+ [ "Goto Next Prompt " slime-repl-next-prompt t ]
+ [ "Clear Last Output" slime-repl-clear-output t ]
+ [ "Clear Buffer " slime-repl-clear-buffer t ]
+ [ "Kill Current Input" slime-repl-kill-input t ])))
+
+(defun slime-repl-add-easy-menu ()
+ (easy-menu-define menubar-slime-repl slime-repl-mode-map
+ "REPL" slime-repl-easy-menu)
+ (easy-menu-define menubar-slime slime-repl-mode-map
+ "SLIME" slime-easy-menu)
+ (easy-menu-add slime-repl-easy-menu 'slime-repl-mode-map))
+
+(add-hook 'slime-repl-mode-hook 'slime-repl-add-easy-menu)
+
+(defun slime-hide-inferior-lisp-buffer ()
+ "Display the REPL buffer instead of the *inferior-lisp* buffer."
+ (let* ((buffer (if (slime-process)
+ (process-buffer (slime-process))))
+ (window (if buffer (get-buffer-window buffer t)))
+ (repl-buffer (slime-output-buffer t))
+ (repl-window (get-buffer-window repl-buffer)))
+ (when buffer
+ (bury-buffer buffer))
+ (cond (repl-window
+ (when window
+ (delete-window window)))
+ (window
+ (set-window-buffer window repl-buffer))
+ (t
+ (pop-to-buffer repl-buffer)
+ (goto-char (point-max))))))
+
+(defun slime-repl-connected-hook-function ()
+ (destructuring-bind (package prompt)
+ (let ((slime-current-thread t))
+ (slime-eval '(swank:create-repl nil)))
+ (setf (slime-lisp-package) package)
+ (setf (slime-lisp-package-prompt-string) prompt))
+ (slime-hide-inferior-lisp-buffer)
+ (slime-init-output-buffer (slime-connection)))
+
+(defun slime-repl-event-hook-function (event)
+ (destructure-case event
+ ((:write-string output &optional target)
+ (slime-write-string output target)
+ t)
+ ((:read-string thread tag)
+ (assert thread)
+ (slime-repl-read-string thread tag)
+ t)
+ ((:read-aborted thread tag)
+ (slime-repl-abort-read thread tag)
+ t)
+ ((:open-dedicated-output-stream port)
+ (slime-open-stream-to-lisp port)
+ t)
+ ((:new-package package prompt-string)
+ (setf (slime-lisp-package) package)
+ (setf (slime-lisp-package-prompt-string) prompt-string)
+ (let ((buffer (slime-connection-output-buffer)))
+ (when (buffer-live-p buffer)
+ (with-current-buffer buffer
+ (setq slime-buffer-package package))))
+ t)
+ (t nil)))
+
+(defun slime-repl-find-buffer-package ()
+ (or (slime-search-buffer-package)
+ (slime-lisp-package)))
+
+;;;###autoload
+(defun slime-repl-init ()
+ (add-hook 'slime-event-hooks 'slime-repl-event-hook-function)
+ (add-hook 'slime-connected-hook 'slime-repl-connected-hook-function)
+ (setq slime-find-buffer-package-function 'slime-repl-find-buffer-package))
+
+(defun slime-repl-remove-hooks ()
+ (remove-hook 'slime-event-hooks 'slime-repl-event-hook-function)
+ (remove-hook 'slime-connected-hook 'slime-repl-connected-hook-function))
+
+(def-slime-test package-updating
+ (package-name nicknames)
+ "Test if slime-lisp-package is updated."
+ '(("COMMON-LISP" ("CL"))
+ ("KEYWORD" ("" "KEYWORD" "||"))
+ ("COMMON-LISP-USER" ("CL-USER")))
+ (with-current-buffer (slime-output-buffer)
+ (let ((p (slime-eval
+ `(swank:listener-eval
+ ,(format
+ "(cl:setq cl:*print-case* :upcase)
+ (cl:setq cl:*package* (cl:find-package %S))
+ (cl:package-name cl:*package*)" package-name))
+ (slime-lisp-package))))
+ (slime-check ("slime-lisp-package is %S." package-name)
+ (equal (slime-lisp-package) package-name))
+ (slime-check ("slime-lisp-package-prompt-string is in %S." nicknames)
+ (member (slime-lisp-package-prompt-string) nicknames)))))
+
+(defmacro with-canonicalized-slime-repl-buffer (&rest body)
+ "Evaluate BODY within a fresh REPL buffer. The REPL prompt is
+canonicalized to \"SWANK\"---we do actually switch to that
+package, though."
+ `(let ((%old-prompt% (slime-lisp-package-prompt-string)))
+ (unwind-protect
+ (progn (with-current-buffer (slime-output-buffer)
+ (setf (slime-lisp-package-prompt-string) "SWANK"))
+ (kill-buffer (slime-output-buffer))
+ (with-current-buffer (slime-output-buffer)
+ ,@body))
+ (setf (slime-lisp-package-prompt-string) %old-prompt%))))
+
+(put 'with-canonicalized-slime-repl-buffer 'lisp-indent-function 0)
+
+(def-slime-test repl-test
+ (input result-contents)
+ "Test simple commands in the minibuffer."
+ '(("(+ 1 2)" "SWANK> (+ 1 2)
+{}3
+SWANK> *[]")
+ ("(princ 10)" "SWANK> (princ 10)
+{10
+}10
+SWANK> *[]")
+ ("(princ 10)(princ 20)" "SWANK> (princ 10)(princ 20)
+{1020
+}20
+SWANK> *[]")
+ ("(dotimes (i 10 77) (princ i) (terpri))"
+ "SWANK> (dotimes (i 10 77) (princ i) (terpri))
+{0
+1
+2
+3
+4
+5
+6
+7
+8
+9
+}77
+SWANK> *[]")
+ ("(abort)" "SWANK> (abort)
+{}; Evaluation aborted.
+SWANK> *[]")
+ ("(progn (princ 10) (force-output) (abort))"
+ "SWANK> (progn (princ 10) (force-output) (abort))
+{10}; Evaluation aborted.
+SWANK> *[]")
+ ("(progn (princ 10) (abort))"
+ ;; output can be flushed after aborting
+ "SWANK> (progn (princ 10) (abort))
+{10}; Evaluation aborted.
+SWANK> *[]")
+ ("(if (fresh-line) 1 0)"
+ "SWANK> (if (fresh-line) 1 0)
+{
+}1
+SWANK> *[]")
+ ("(values 1 2 3)" "SWANK> (values 1 2 3)
+{}1
+2
+3
+SWANK> *[]")
+ ("(with-standard-io-syntax
+ (write (make-list 15 :initial-element '(1 . 2)) :pretty t) 0)"
+ "SWANK> (with-standard-io-syntax
+ (write (make-list 15 :initial-element '(1 . 2)) :pretty t) 0)
+{((1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2)
+ (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2))
+}0
+SWANK> *[]")
+ ;; Two times to test the effect of FRESH-LINE.
+ ("(with-standard-io-syntax
+ (write (make-list 15 :initial-element '(1 . 2)) :pretty t) 0)"
+ "SWANK> (with-standard-io-syntax
+ (write (make-list 15 :initial-element '(1 . 2)) :pretty t) 0)
+{((1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2)
+ (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2))
+}0
+SWANK> *[]"))
+ (with-canonicalized-slime-repl-buffer
+ (insert input)
+ (slime-check-buffer-contents "Buffer contains input"
+ (concat "{}SWANK> [" input "*]"))
+ (call-interactively 'slime-repl-return)
+ (slime-sync-to-top-level 5)
+ (slime-check-buffer-contents "Buffer contains result" result-contents)))
+
+(defun slime-check-buffer-contents (msg expected)
+ (let* ((marks '((point . ?*)
+ (slime-output-start . ?{) (slime-output-end . ?})
+ (slime-repl-input-start-mark . ?\[) (point-max . ?\])))
+ (marks (remove-if-not (lambda (m) (position (cdr m) expected))
+ marks))
+ (marks (sort (copy-sequence marks)
+ (lambda (x y)
+ (< (position (cdr x) expected)
+ (position (cdr y) expected)))))
+ (content (remove-if (lambda (c) (member* c marks :key #'cdr))
+ expected))
+ (marks (do ((result '() (acons (caar m) (1+ (position (cdar m) s))
+ result))
+ (m marks (cdr m))
+ (s expected (remove* (cdar m) s)))
+ ((null m) (reverse result))))
+ (point (point))
+ (point-max (point-max)))
+ (slime-test-expect (concat msg " [content]") content (buffer-string))
+ (macrolet ((test-mark
+ (mark)
+ `(when (assoc ',mark marks)
+ (slime-test-expect (format "%s [%s]" msg ',mark)
+ (cdr (assoc ',mark marks))
+ ,mark
+ #'=))))
+ (test-mark point)
+ (test-mark slime-output-end)
+ (test-mark slime-output-start)
+ (test-mark slime-repl-input-start-mark)
+ (test-mark point-max))))
+
+(def-slime-test repl-return
+ (before after result-contents)
+ "Test if slime-repl-return sends the correct protion to Lisp even
+if point is not at the end of the line."
+ '(("(+ 1 2)" "" "SWANK> (+ 1 2)
+3
+SWANK> ")
+("(+ 1 " "2)" "SWANK> (+ 1 2)
+3
+SWANK> ")
+
+("(+ 1\n" "2)" "SWANK> (+ 1
+2)
+3
+SWANK> "))
+ (with-canonicalized-slime-repl-buffer
+ (insert before)
+ (save-excursion (insert after))
+ (slime-test-expect "Buffer contains input"
+ (concat "SWANK> " before after)
+ (buffer-string))
+ (call-interactively 'slime-repl-return)
+ (slime-sync-to-top-level 5)
+ (slime-test-expect "Buffer contains result"
+ result-contents (buffer-string))))
+
+(def-slime-test repl-read
+ (prompt input result-contents)
+ "Test simple commands in the minibuffer."
+ '(("(read-line)" "foo" "SWANK> (values (read-line))
+foo
+\"foo\"
+SWANK> ")
+ ("(read-char)" "1" "SWANK> (values (read-char))
+1
+#\\1
+SWANK> ")
+ ("(read)" "(+ 2 3
+4)" "SWANK> (values (read))
+\(+ 2 3
+4)
+\(+ 2 3 4)
+SWANK> "))
+ (with-canonicalized-slime-repl-buffer
+ (insert (format "(values %s)" prompt))
+ (call-interactively 'slime-repl-return)
+ (slime-wait-condition "reading" #'slime-reading-p 5)
+ (insert input)
+ (call-interactively 'slime-repl-return)
+ (slime-sync-to-top-level 5)
+ (slime-test-expect "Buffer contains result"
+ result-contents (buffer-string))))
+
+(def-slime-test repl-read-lines
+ (command inputs final-contents)
+ "Test reading multiple lines from the repl."
+ '(("(list (read-line) (read-line) (read-line))"
+ ("a" "b" "c")
+ "SWANK> (list (read-line) (read-line) (read-line))
+a
+b
+c
+\(\"a\" \"b\" \"c\")
+SWANK> "))
+ (with-canonicalized-slime-repl-buffer
+ (insert command)
+ (call-interactively 'slime-repl-return)
+ (dolist (input inputs)
+ (slime-wait-condition "reading" #'slime-reading-p 5)
+ (insert input)
+ (call-interactively 'slime-repl-return))
+ (slime-sync-to-top-level 5)
+ (slime-test-expect "Buffer contains result"
+ final-contents
+ (buffer-string)
+ #'equal)))
+
+(def-slime-test repl-type-ahead
+ (command input final-contents)
+ "Ensure that user input is preserved correctly.
+In particular, input inserted while waiting for a result."
+ '(("(sleep 0.1)" "foo*" "SWANK> (sleep 0.1)
+{}NIL
+SWANK> [foo*]")
+ ("(sleep 0.1)" "*foo" "SWANK> (sleep 0.1)
+{}NIL
+SWANK> [*foo]")
+ ("(progn (sleep 0.1) (abort))" "*foo" "SWANK> (progn (sleep 0.1) (abort))
+{}; Evaluation aborted.
+SWANK> [*foo]"))
+ (with-canonicalized-slime-repl-buffer
+ (insert command)
+ (call-interactively 'slime-repl-return)
+ (save-excursion (insert (delete* ?* input)))
+ (forward-char (position ?* input))
+ (slime-sync-to-top-level 5)
+ (slime-check-buffer-contents "Buffer contains result" final-contents)))
+
+
+(def-slime-test interrupt-in-blocking-read
+ ()
+ "Let's see what happens if we interrupt a blocking read operation."
+ '(())
+ (slime-check-top-level)
+ (with-canonicalized-slime-repl-buffer
+ (insert "(read-char)")
+ (call-interactively 'slime-repl-return)
+ (slime-wait-condition "reading" #'slime-reading-p 5)
+ (slime-interrupt)
+ (slime-wait-condition "Debugger visible"
+ (lambda ()
+ (and (slime-sldb-level= 1)
+ (get-buffer-window (sldb-get-default-buffer))))
+ 5)
+ (with-current-buffer (sldb-get-default-buffer)
+ (sldb-continue))
+ (slime-wait-condition "reading" #'slime-reading-p 5)
+ (with-current-buffer (slime-output-buffer)
+ (insert "X")
+ (call-interactively 'slime-repl-return)
+ (slime-sync-to-top-level 5)
+ (slime-test-expect "Buffer contains result"
+ "SWANK> (read-char)
+X
+#\\X
+SWANK> " (buffer-string)))))
+
+(let ((byte-compile-warnings '()))
+ (mapc #'byte-compile
+ '(slime-repl-event-hook-function
+ slime-write-string
+ slime-repl-write-string
+ slime-repl-emit
+ slime-repl-show-maximum-output)))
+
+;;;###autoload
+(add-hook 'slime-load-hook 'slime-repl-init)
+
+(provide 'slime-repl)
+;;; slime-repl.el ends here
View
9,056 lein-swank/src/swank/payload/slime.el
9,056 additions, 0 deletions not shown
Please sign in to comment.
Something went wrong with that request. Please try again.