/[slime]/slime/contrib/slime-repl.el
ViewVC logotype

Contents of /slime/contrib/slime-repl.el

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.67 - (show annotations)
Mon May 13 13:16:24 2013 UTC (11 months ago) by mbaringer
Branch: MAIN
CVS Tags: HEAD
Changes since 1.66: +17 -1 lines
slime-repl.el (slime-repl-sexp-at-point): New function ; similar
to slime-sexp-at-point but ignore repl prompt text.
(slime-repl-inspect): New function; similar to slime-inspect but
default value is computed via slime-repl-sexp-at-point and not
slime-sexp-at-point.
(slime-repl-mode-map): Bind slime-repl-inspect it C-c I
1 ;;; slime-repl.el ---
2 ;;
3 ;; Original Author: Helmut Eller
4 ;; Contributors: to many to mention
5 ;; License: GNU GPL (same license as Emacs)
6 ;;
7 ;;; Description:
8 ;;
9
10 ;;
11 ;;; Installation:
12 ;;
13 ;; Call slime-setup and include 'slime-repl as argument:
14 ;;
15 ;; (slime-setup '(slime-repl [others conribs ...]))
16 ;;
17
18 (define-slime-contrib slime-repl
19 "Read-Eval-Print Loop written in Emacs Lisp.
20
21 This contrib implements a Lisp Listener along with some niceties like
22 a persistent history and various \"shortcut\" commands. Nothing here
23 depends on comint.el; I/O is multiplexed over SLIME's socket.
24
25 This used to be the default REPL for SLIME, but it was hard to
26 maintain."
27 (:authors "too many to mention")
28 (:license "GPL")
29 (:on-load
30 (slime-repl-add-hooks)
31 (setq slime-find-buffer-package-function 'slime-repl-find-buffer-package))
32 (:on-unload (slime-repl-remove-hooks))
33 (:swank-dependencies swank-repl))
34
35 ;;;;; slime-repl
36
37 (defgroup slime-repl nil
38 "The Read-Eval-Print Loop (*slime-repl* buffer)."
39 :prefix "slime-repl-"
40 :group 'slime)
41
42 (defcustom slime-repl-shortcut-dispatch-char ?\,
43 "Character used to distinguish repl commands from lisp forms."
44 :type '(character)
45 :group 'slime-repl)
46
47 (defcustom slime-repl-only-save-lisp-buffers t
48 "When T we only attempt to save lisp-mode file buffers. When
49 NIL slime will attempt to save all buffers (as per
50 save-some-buffers). This applies to all ASDF related repl
51 shortcuts."
52 :type '(boolean)
53 :group 'slime-repl)
54
55 (defcustom slime-repl-auto-right-margin nil
56 "When T we bind CL:*PRINT-RIGHT-MARGIN* to the width of the
57 current repl's (as per slime-output-buffer) window."
58 :type '(boolean)
59 :group 'slime-repl)
60
61 (defface slime-repl-prompt-face
62 (if (slime-face-inheritance-possible-p)
63 '((t (:inherit font-lock-keyword-face)))
64 '((((class color) (background light)) (:foreground "Purple"))
65 (((class color) (background dark)) (:foreground "Cyan"))
66 (t (:weight bold))))
67 "Face for the prompt in the SLIME REPL."
68 :group 'slime-repl)
69
70 (defface slime-repl-output-face
71 (if (slime-face-inheritance-possible-p)
72 '((t (:inherit font-lock-string-face)))
73 '((((class color) (background light)) (:foreground "RosyBrown"))
74 (((class color) (background dark)) (:foreground "LightSalmon"))
75 (t (:slant italic))))
76 "Face for Lisp output in the SLIME REPL."
77 :group 'slime-repl)
78
79 (defface slime-repl-input-face
80 '((t (:bold t)))
81 "Face for previous input in the SLIME REPL."
82 :group 'slime-repl)
83
84 (defface slime-repl-result-face
85 '((t ()))
86 "Face for the result of an evaluation in the SLIME REPL."
87 :group 'slime-repl)
88
89 (defcustom slime-repl-history-file "~/.slime-history.eld"
90 "File to save the persistent REPL history to."
91 :type 'string
92 :group 'slime-repl)
93
94 (defcustom slime-repl-history-size 200
95 "*Maximum number of lines for persistent REPL history."
96 :type 'integer
97 :group 'slime-repl)
98
99 (defcustom slime-repl-history-file-coding-system
100 (cond ((slime-find-coding-system 'utf-8-unix) 'utf-8-unix)
101 (t slime-net-coding-system))
102 "*The coding system for the history file."
103 :type 'symbol
104 :group 'slime-repl)
105
106
107 ;; dummy defvar for compiler
108 (defvar slime-repl-read-mode)
109
110 (defun slime-reading-p ()
111 "True if Lisp is currently reading input from the REPL."
112 (with-current-buffer (slime-output-buffer)
113 slime-repl-read-mode))
114
115
116 ;;;; Stream output
117
118 (slime-def-connection-var slime-connection-output-buffer nil
119 "The buffer for the REPL. May be nil or a dead buffer.")
120
121 (make-variable-buffer-local
122 (defvar slime-output-start nil
123 "Marker for the start of the output for the evaluation."))
124
125 (make-variable-buffer-local
126 (defvar slime-output-end nil
127 "Marker for end of output. New output is inserted at this mark."))
128
129 ;; dummy definitions for the compiler
130 (defvar slime-repl-package-stack)
131 (defvar slime-repl-directory-stack)
132 (defvar slime-repl-input-start-mark)
133 (defvar slime-repl-prompt-start-mark)
134
135 (defun slime-output-buffer (&optional noprompt)
136 "Return the output buffer, create it if necessary."
137 (let ((buffer (slime-connection-output-buffer)))
138 (or (if (buffer-live-p buffer) buffer)
139 (setf (slime-connection-output-buffer)
140 (let ((connection (slime-connection)))
141 (with-current-buffer (slime-repl-buffer t connection)
142 (unless (eq major-mode 'slime-repl-mode)
143 (slime-repl-mode))
144 (setq slime-buffer-connection connection)
145 (setq slime-buffer-package (slime-lisp-package connection))
146 (slime-reset-repl-markers)
147 (unless noprompt
148 (slime-repl-insert-prompt))
149 (current-buffer)))))))
150
151 (defvar slime-repl-banner-function 'slime-repl-insert-banner)
152
153 (defun slime-repl-update-banner ()
154 (funcall slime-repl-banner-function)
155 (slime-move-point (point-max))
156 (slime-mark-output-start)
157 (slime-mark-input-start)
158 (slime-repl-insert-prompt))
159
160 (defun slime-repl-insert-banner ()
161 (when (zerop (buffer-size))
162 (let ((welcome (concat "; SLIME " (or (slime-changelog-date)
163 "- ChangeLog file not found"))))
164 (insert welcome))))
165
166 (defun slime-init-output-buffer (connection)
167 (with-current-buffer (slime-output-buffer t)
168 (setq slime-buffer-connection connection
169 slime-repl-directory-stack '()
170 slime-repl-package-stack '())
171 (slime-repl-update-banner)))
172
173 (defun slime-display-output-buffer ()
174 "Display the output buffer and scroll to bottom."
175 (with-current-buffer (slime-output-buffer)
176 (goto-char (point-max))
177 (unless (get-buffer-window (current-buffer) t)
178 (display-buffer (current-buffer) t))
179 (slime-repl-show-maximum-output)))
180
181 (defun slime-output-filter (process string)
182 (with-current-buffer (process-buffer process)
183 (when (and (plusp (length string))
184 (eq (process-status slime-buffer-connection) 'open))
185 (slime-write-string string))))
186
187 (defvar slime-open-stream-hooks)
188
189 (defun slime-open-stream-to-lisp (port coding-system)
190 (let ((stream (open-network-stream "*lisp-output-stream*"
191 (slime-with-connection-buffer ()
192 (current-buffer))
193 (car (process-contact (slime-connection)))
194 port))
195 (emacs-coding-system (car (find coding-system
196 slime-net-valid-coding-systems
197 :key #'third))))
198 (slime-set-query-on-exit-flag stream)
199 (set-process-filter stream 'slime-output-filter)
200 (set-process-coding-system stream emacs-coding-system emacs-coding-system)
201 (when-let (secret (slime-secret))
202 (slime-net-send secret stream))
203 (run-hook-with-args 'slime-open-stream-hooks stream)
204 stream))
205
206 (defun slime-io-speed-test (&optional profile)
207 "A simple minded benchmark for stream performance.
208 If a prefix argument is given, instrument the slime package for
209 profiling before running the benchmark."
210 (interactive "P")
211 (eval-and-compile
212 (require 'elp))
213 (elp-reset-all)
214 (elp-restore-all)
215 (load "slime.el")
216 ;;(byte-compile-file "slime-net.el" t)
217 ;;(setq slime-log-events nil)
218 (setq slime-enable-evaluate-in-emacs t)
219 ;;(setq slime-repl-enable-presentations nil)
220 (when profile
221 (elp-instrument-package "slime-"))
222 (kill-buffer (slime-output-buffer))
223 (switch-to-buffer (slime-output-buffer))
224 (delete-other-windows)
225 (sit-for 0)
226 (slime-repl-send-string "(swank:io-speed-test 4000 1)")
227 (let ((proc (slime-inferior-process)))
228 (when proc
229 (display-buffer (process-buffer proc) t)
230 (goto-char (point-max)))))
231
232 (defvar slime-write-string-function 'slime-repl-write-string)
233
234 (defun slime-write-string (string &optional target)
235 "Insert STRING in the REPL buffer or some other TARGET.
236 If TARGET is nil, insert STRING as regular process
237 output. If TARGET is :repl-result, insert STRING as the result of the
238 evaluation. Other values of TARGET map to an Emacs marker via the
239 hashtable `slime-output-target-to-marker'; output is inserted at this marker."
240 (funcall slime-write-string-function string target))
241
242 (defun slime-repl-write-string (string &optional target)
243 (case target
244 ((nil) (slime-repl-emit string))
245 (:repl-result (slime-repl-emit-result string))
246 (t (slime-emit-to-target string target))))
247
248 (defvar slime-repl-popup-on-output nil
249 "Display the output buffer when some output is written.
250 This is set to nil after displaying the buffer.")
251
252 (defmacro slime-save-marker (marker &rest body)
253 (let ((pos (gensym "pos")))
254 `(let ((,pos (marker-position ,marker)))
255 (prog1 (progn . ,body)
256 (set-marker ,marker ,pos)))))
257
258 (put 'slime-save-marker 'lisp-indent-function 1)
259
260 (defun slime-repl-emit (string)
261 ;; insert the string STRING in the output buffer
262 (with-current-buffer (slime-output-buffer)
263 (save-excursion
264 (goto-char slime-output-end)
265 (slime-save-marker slime-output-start
266 (slime-propertize-region '(face slime-repl-output-face
267 rear-nonsticky (face))
268 (insert-before-markers string)
269 (when (and (= (point) slime-repl-prompt-start-mark)
270 (not (bolp)))
271 (insert-before-markers "\n")
272 (set-marker slime-output-end (1- (point)))))))
273 (when slime-repl-popup-on-output
274 (setq slime-repl-popup-on-output nil)
275 (display-buffer (current-buffer)))
276 (slime-repl-show-maximum-output)))
277
278 (defun slime-repl-emit-result (string &optional bol)
279 ;; insert STRING and mark it as evaluation result
280 (with-current-buffer (slime-output-buffer)
281 (save-excursion
282 (slime-save-marker slime-output-start
283 (slime-save-marker slime-output-end
284 (goto-char slime-repl-input-start-mark)
285 (when (and bol (not (bolp))) (insert-before-markers "\n"))
286 (slime-propertize-region `(face slime-repl-result-face
287 rear-nonsticky (face))
288 (insert-before-markers string)))))
289 (slime-repl-show-maximum-output)))
290
291 (defvar slime-last-output-target-id 0
292 "The last integer we used as a TARGET id.")
293
294 (defvar slime-output-target-to-marker
295 (make-hash-table)
296 "Map from TARGET ids to Emacs markers.
297 The markers indicate where output should be inserted.")
298
299 (defun slime-output-target-marker (target)
300 "Return the marker where output for TARGET should be inserted."
301 (case target
302 ((nil)
303 (with-current-buffer (slime-output-buffer)
304 slime-output-end))
305 (:repl-result
306 (with-current-buffer (slime-output-buffer)
307 slime-repl-input-start-mark))
308 (t
309 (gethash target slime-output-target-to-marker))))
310
311 (defun slime-emit-to-target (string target)
312 "Insert STRING at target TARGET.
313 See `slime-output-target-to-marker'."
314 (let* ((marker (slime-output-target-marker target))
315 (buffer (and marker (marker-buffer marker))))
316 (when buffer
317 (with-current-buffer buffer
318 (save-excursion
319 ;; Insert STRING at MARKER, then move MARKER behind
320 ;; the insertion.
321 (goto-char marker)
322 (insert-before-markers string)
323 (set-marker marker (point)))))))
324
325 (defun slime-switch-to-output-buffer ()
326 "Select the output buffer, when possible in an existing window.
327
328 Hint: You can use `display-buffer-reuse-frames' and
329 `special-display-buffer-names' to customize the frame in which
330 the buffer should appear."
331 (interactive)
332 (slime-pop-to-buffer (slime-output-buffer))
333 (goto-char (point-max)))
334
335
336 ;;;; REPL
337 ;;
338 ;; The REPL uses some markers to separate input from output. The
339 ;; usual configuration is as follows:
340 ;;
341 ;; ... output ... ... result ... prompt> ... input ...
342 ;; ^ ^ ^ ^ ^
343 ;; output-start output-end prompt-start input-start point-max
344 ;;
345 ;; input-start is a right inserting marker, because
346 ;; we want it to stay behind when the user inserts text.
347 ;;
348 ;; We maintain the following invariant:
349 ;;
350 ;; output-start <= output-end <= input-start.
351 ;;
352 ;; This invariant is important, because we must be prepared for
353 ;; asynchronous output and asynchronous reads. ("Asynchronous" means,
354 ;; triggered by Lisp and not by Emacs.)
355 ;;
356 ;; All output is inserted at the output-end marker. Some care must be
357 ;; taken when output-end and input-start are at the same position: if
358 ;; we insert at that point, we must move the right markers. We should
359 ;; also not leave (window-)point in the middle of the new output. The
360 ;; idiom we use is a combination to slime-save-marker,
361 ;; insert-before-markers, and manually updating window-point
362 ;; afterwards.
363 ;;
364 ;; A "synchronous" evaluation request proceeds as follows: the user
365 ;; inserts some text between input-start and point-max and then hits
366 ;; return. We send that region to Lisp, move the output and input
367 ;; makers to the line after the input and wait. When we receive the
368 ;; result, we insert it together with a prompt between the output-end
369 ;; and input-start mark. See `slime-repl-insert-prompt'.
370 ;;
371 ;; It is possible that some output for such an evaluation request
372 ;; arrives after the result. This output is inserted before the
373 ;; result (and before the prompt).
374 ;;
375 ;; If we are in "reading" state, e.g., during a call to Y-OR-N-P,
376 ;; there is no prompt between output-end and input-start.
377 ;;
378
379 ;; FIXME: slime-lisp-package should be local in a REPL buffer
380 (slime-def-connection-var slime-lisp-package
381 "COMMON-LISP-USER"
382 "The current package name of the Superior lisp.
383 This is automatically synchronized from Lisp.")
384
385 (slime-def-connection-var slime-lisp-package-prompt-string
386 "CL-USER"
387 "The current package name of the Superior lisp.
388 This is automatically synchronized from Lisp.")
389
390 (slime-make-variables-buffer-local
391 (defvar slime-repl-package-stack nil
392 "The stack of packages visited in this repl.")
393
394 (defvar slime-repl-directory-stack nil
395 "The stack of default directories associated with this repl.")
396
397 (defvar slime-repl-prompt-start-mark)
398 (defvar slime-repl-input-start-mark)
399 (defvar slime-repl-old-input-counter 0
400 "Counter used to generate unique `slime-repl-old-input' properties.
401 This property value must be unique to avoid having adjacent inputs be
402 joined together."))
403
404 (defun slime-reset-repl-markers ()
405 (dolist (markname '(slime-output-start
406 slime-output-end
407 slime-repl-prompt-start-mark
408 slime-repl-input-start-mark))
409 (set markname (make-marker))
410 (set-marker (symbol-value markname) (point))))
411
412 ;;;;; REPL mode setup
413
414 (defvar slime-repl-mode-map
415 (let ((map (make-sparse-keymap)))
416 (set-keymap-parent map lisp-mode-map)
417 map))
418
419 (slime-define-keys slime-prefix-map
420 ("\C-z" 'slime-switch-to-output-buffer)
421 ("\M-p" 'slime-repl-set-package))
422
423 (slime-define-keys slime-mode-map
424 ("\C-c~" 'slime-sync-package-and-default-directory)
425 ("\C-c\C-y" 'slime-call-defun)
426 ("\C-c\C-j" 'slime-eval-last-expression-in-repl))
427
428 (slime-define-keys slime-connection-list-mode-map
429 ((kbd "RET") 'slime-goto-connection)
430 ([return] 'slime-goto-connection))
431
432 (slime-define-keys slime-repl-mode-map
433 ("\C-m" 'slime-repl-return)
434 ([return] 'slime-repl-return)
435 ("\C-j" 'slime-repl-newline-and-indent)
436 ("\C-\M-m" 'slime-repl-closing-return)
437 ([(control return)] 'slime-repl-closing-return)
438 ("\C-a" 'slime-repl-bol)
439 ([home] 'slime-repl-bol)
440 ("\M-p" 'slime-repl-previous-input)
441 ((kbd "C-<up>") 'slime-repl-backward-input)
442 ("\M-n" 'slime-repl-next-input)
443 ((kbd "C-<down>") 'slime-repl-forward-input)
444 ("\M-r" 'slime-repl-previous-matching-input)
445 ("\M-s" 'slime-repl-next-matching-input)
446 ("\C-c\C-c" 'slime-interrupt)
447 ;("\t" 'slime-complete-symbol)
448 ("\t" 'slime-indent-and-complete-symbol)
449 ("\M-\t" 'slime-complete-symbol)
450 (" " 'slime-space)
451 ("\C-c\C-o" 'slime-repl-clear-output)
452 ("\C-c\M-o" 'slime-repl-clear-buffer)
453 ("\C-c\C-u" 'slime-repl-kill-input)
454 ("\C-c\C-n" 'slime-repl-next-prompt)
455 ("\C-c\C-p" 'slime-repl-previous-prompt)
456 ("\C-c\C-z" 'slime-nop)
457 ("\C-cI" 'slime-repl-inspect))
458
459 (slime-define-keys slime-inspector-mode-map
460 ((kbd "M-RET") 'slime-inspector-copy-down-to-repl))
461
462 (slime-define-keys sldb-mode-map
463 ("\C-y" 'sldb-insert-frame-call-to-repl))
464
465 (def-slime-selector-method ?r
466 "SLIME Read-Eval-Print-Loop."
467 (slime-output-buffer))
468
469 (define-minor-mode slime-repl-map-mode
470 "Minor mode which makes slime-repl-mode-map available.
471 \\{slime-repl-mode-map}"
472 nil
473 nil
474 slime-repl-mode-map)
475
476 (defun slime-repl-mode ()
477 "Major mode for interacting with a superior Lisp.
478 \\{slime-repl-mode-map}"
479 (interactive)
480 (kill-all-local-variables)
481 (setq major-mode 'slime-repl-mode)
482 (slime-editing-mode 1)
483 (slime-repl-map-mode 1)
484 (lisp-mode-variables t)
485 (set (make-local-variable 'lisp-indent-function)
486 'common-lisp-indent-function)
487 (setq font-lock-defaults nil)
488 (setq mode-name "REPL")
489 (setq slime-current-thread :repl-thread)
490 (set (make-local-variable 'scroll-conservatively) 20)
491 (set (make-local-variable 'scroll-margin) 0)
492 (when slime-repl-history-file
493 (slime-repl-safe-load-history)
494 (slime-add-local-hook 'kill-buffer-hook
495 'slime-repl-safe-save-merged-history))
496 (add-hook 'kill-emacs-hook 'slime-repl-save-all-histories)
497 (slime-setup-command-hooks)
498 ;; At the REPL, we define beginning-of-defun and end-of-defun to be
499 ;; the start of the previous prompt or next prompt respectively.
500 ;; Notice the interplay with SLIME-REPL-BEGINNING-OF-DEFUN.
501 (set (make-local-variable 'beginning-of-defun-function)
502 'slime-repl-mode-beginning-of-defun)
503 (set (make-local-variable 'end-of-defun-function)
504 'slime-repl-mode-end-of-defun)
505 (slime-run-mode-hooks 'slime-repl-mode-hook))
506
507 (defun slime-repl-buffer (&optional create connection)
508 "Get the REPL buffer for the current connection; optionally create."
509 (funcall (if create #'get-buffer-create #'get-buffer)
510 (format "*slime-repl %s*" (slime-connection-name connection))))
511
512 (defun slime-repl ()
513 (interactive)
514 (slime-switch-to-output-buffer))
515
516 (defun slime-repl-mode-beginning-of-defun (&optional arg)
517 (if (and arg (< arg 0))
518 (slime-repl-mode-end-of-defun (- arg))
519 (dotimes (i (or arg 1))
520 (slime-repl-previous-prompt))))
521
522 (defun slime-repl-mode-end-of-defun (&optional arg)
523 (if (and arg (< arg 0))
524 (slime-repl-mode-beginning-of-defun (- arg))
525 (dotimes (i (or arg 1))
526 (slime-repl-next-prompt))))
527
528 (defun slime-repl-send-string (string &optional command-string)
529 (cond (slime-repl-read-mode
530 (slime-repl-return-string string))
531 (t (slime-repl-eval-string string))))
532
533 (defun slime-repl-eval-string (string)
534 (slime-rex ()
535 ((if slime-repl-auto-right-margin
536 `(swank:listener-eval ,string
537 :window-width
538 ,(with-current-buffer (slime-output-buffer)
539 (window-width)))
540 `(swank:listener-eval ,string))
541 (slime-lisp-package))
542 ((:ok result)
543 (slime-repl-insert-result result))
544 ((:abort condition)
545 (slime-repl-show-abort condition))))
546
547 (defun slime-repl-insert-result (result)
548 (with-current-buffer (slime-output-buffer)
549 (save-excursion
550 (when result
551 (destructure-case result
552 ((:values &rest strings)
553 (cond ((null strings)
554 (slime-repl-emit-result "; No value\n" t))
555 (t
556 (dolist (s strings)
557 (slime-repl-emit-result s t)))))))
558 (slime-repl-insert-prompt))
559 (slime-repl-show-maximum-output)))
560
561 (defun slime-repl-show-abort (condition)
562 (with-current-buffer (slime-output-buffer)
563 (save-excursion
564 (slime-save-marker slime-output-start
565 (slime-save-marker slime-output-end
566 (goto-char slime-output-end)
567 (insert-before-markers (format "; Evaluation aborted on %s.\n"
568 condition))
569 (slime-repl-insert-prompt))))
570 (slime-repl-show-maximum-output)))
571
572 (defvar slime-repl-suppress-prompt nil
573 "Supresses Slime REPL prompt when bound to T.")
574
575 (defun slime-repl-insert-prompt ()
576 "Insert the prompt (before markers!).
577 Set point after the prompt.
578 Return the position of the prompt beginning.
579
580 If `slime-repl-suppress-prompt' is true, does nothing and returns nil."
581 (goto-char slime-repl-input-start-mark)
582 (unless slime-repl-suppress-prompt
583 (slime-save-marker slime-output-start
584 (slime-save-marker slime-output-end
585 (unless (bolp) (insert-before-markers "\n"))
586 (let ((prompt-start (point))
587 (prompt (format "%s> " (slime-lisp-package-prompt-string))))
588 (slime-propertize-region
589 '(face slime-repl-prompt-face read-only t intangible t
590 slime-repl-prompt t
591 ;; emacs stuff
592 rear-nonsticky (slime-repl-prompt read-only face
593 intangible)
594 ;; xemacs stuff
595 start-open t end-open t)
596 (insert-before-markers prompt))
597 (set-marker slime-repl-prompt-start-mark prompt-start)
598 prompt-start)))))
599
600 (defun slime-repl-show-maximum-output ()
601 "Put the end of the buffer at the bottom of the window."
602 (when (eobp)
603 (let ((win (if (eq (window-buffer) (current-buffer))
604 (selected-window)
605 (get-buffer-window (current-buffer) t))))
606 (when win
607 (with-selected-window win
608 (set-window-point win (point-max))
609 (recenter -1))))))
610
611 (defvar slime-repl-current-input-hooks)
612
613 (defun slime-repl-current-input (&optional until-point-p)
614 "Return the current input as string.
615 The input is the region from after the last prompt to the end of
616 buffer."
617 (or (run-hook-with-args-until-success 'slime-repl-current-input-hooks
618 until-point-p)
619 (buffer-substring-no-properties slime-repl-input-start-mark
620 (if until-point-p
621 (point)
622 (point-max)))))
623
624 (defun slime-property-position (text-property &optional object)
625 "Return the first position of TEXT-PROPERTY, or nil."
626 (if (get-text-property 0 text-property object)
627 0
628 (next-single-property-change 0 text-property object)))
629
630 (defun slime-mark-input-start ()
631 (set-marker slime-repl-input-start-mark (point) (current-buffer)))
632
633 (defun slime-mark-output-start ()
634 (set-marker slime-output-start (point))
635 (set-marker slime-output-end (point)))
636
637 (defun slime-mark-output-end ()
638 ;; Don't put slime-repl-output-face again; it would remove the
639 ;; special presentation face, for instance in the SBCL inspector.
640 (add-text-properties slime-output-start slime-output-end
641 '(;;face slime-repl-output-face
642 rear-nonsticky (face))))
643
644 (defun slime-repl-bol ()
645 "Go to the beginning of line or the prompt."
646 (interactive)
647 (cond ((and (>= (point) slime-repl-input-start-mark)
648 (slime-same-line-p (point) slime-repl-input-start-mark))
649 (goto-char slime-repl-input-start-mark))
650 (t (beginning-of-line 1)))
651 (slime-preserve-zmacs-region))
652
653 (defun slime-preserve-zmacs-region ()
654 "In XEmacs, ensure that the zmacs-region stays active after this command."
655 (when (boundp 'zmacs-region-stays)
656 (set 'zmacs-region-stays t)))
657
658 (defun slime-repl-in-input-area-p ()
659 (<= slime-repl-input-start-mark (point)))
660
661 (defun slime-repl-at-prompt-start-p ()
662 ;; This will not work on non-current prompts.
663 (= (point) slime-repl-input-start-mark))
664
665 (defun slime-repl-beginning-of-defun ()
666 "Move to beginning of defun."
667 (interactive)
668 ;; We call BEGINNING-OF-DEFUN if we're at the start of a prompt
669 ;; already, to trigger SLIME-REPL-MODE-BEGINNING-OF-DEFUN by means
670 ;; of the locally bound BEGINNING-OF-DEFUN-FUNCTION, in order to
671 ;; jump to the start of the previous prompt.
672 (if (and (not (slime-repl-at-prompt-start-p))
673 (slime-repl-in-input-area-p))
674 (goto-char slime-repl-input-start-mark)
675 (beginning-of-defun))
676 t)
677
678 ;; FIXME: this looks very strange
679 (defun slime-repl-end-of-defun ()
680 "Move to next of defun."
681 (interactive)
682 ;; C.f. SLIME-REPL-BEGINNING-OF-DEFUN.
683 (if (and (not (= (point) (point-max)))
684 (slime-repl-in-input-area-p))
685 (goto-char (point-max))
686 (end-of-defun))
687 t)
688
689 (defun slime-repl-previous-prompt ()
690 "Move backward to the previous prompt."
691 (interactive)
692 (slime-repl-find-prompt t))
693
694 (defun slime-repl-next-prompt ()
695 "Move forward to the next prompt."
696 (interactive)
697 (slime-repl-find-prompt))
698
699 (defun slime-repl-find-prompt (&optional backward)
700 (let ((origin (point))
701 (prop 'slime-repl-prompt))
702 (while (progn
703 (slime-search-property-change prop backward)
704 (not (or (slime-end-of-proprange-p prop) (bobp) (eobp)))))
705 (unless (slime-end-of-proprange-p prop)
706 (goto-char origin))))
707
708 (defun slime-search-property-change (prop &optional backward)
709 (cond (backward
710 (goto-char (or (previous-single-char-property-change (point) prop)
711 (point-min))))
712 (t
713 (goto-char (or (next-single-char-property-change (point) prop)
714 (point-max))))))
715
716 (defun slime-end-of-proprange-p (property)
717 (and (get-char-property (max 1 (1- (point))) property)
718 (not (get-char-property (point) property))))
719
720 (defvar slime-repl-return-hooks)
721
722 (defun slime-repl-return (&optional end-of-input)
723 "Evaluate the current input string, or insert a newline.
724 Send the current input only if a whole expression has been entered,
725 i.e. the parenthesis are matched.
726
727 With prefix argument send the input even if the parenthesis are not
728 balanced."
729 (interactive "P")
730 (slime-check-connected)
731 (cond (end-of-input
732 (slime-repl-send-input))
733 (slime-repl-read-mode ; bad style?
734 (slime-repl-send-input t))
735 ((and (get-text-property (point) 'slime-repl-old-input)
736 (< (point) slime-repl-input-start-mark))
737 (slime-repl-grab-old-input end-of-input)
738 (slime-repl-recenter-if-needed))
739 ((run-hook-with-args-until-success 'slime-repl-return-hooks))
740 ((slime-input-complete-p slime-repl-input-start-mark (point-max))
741 (slime-repl-send-input t))
742 (t
743 (slime-repl-newline-and-indent)
744 (message "[input not complete]"))))
745
746 (defun slime-repl-recenter-if-needed ()
747 "Make sure that (point) is visible."
748 (unless (pos-visible-in-window-p (point-max))
749 (save-excursion
750 (goto-char (point-max))
751 (recenter -1))))
752
753 (defun slime-repl-send-input (&optional newline)
754 "Goto to the end of the input and send the current input.
755 If NEWLINE is true then add a newline at the end of the input."
756 (unless (slime-repl-in-input-area-p)
757 (error "No input at point."))
758 (goto-char (point-max))
759 (let ((end (point))) ; end of input, without the newline
760 (slime-repl-add-to-input-history
761 (buffer-substring slime-repl-input-start-mark end))
762 (when newline
763 (insert "\n")
764 (slime-repl-show-maximum-output))
765 (let ((inhibit-modification-hooks t))
766 (add-text-properties slime-repl-input-start-mark
767 (point)
768 `(slime-repl-old-input
769 ,(incf slime-repl-old-input-counter))))
770 (let ((overlay (make-overlay slime-repl-input-start-mark end)))
771 ;; These properties are on an overlay so that they won't be taken
772 ;; by kill/yank.
773 (overlay-put overlay 'face 'slime-repl-input-face)))
774 (let ((input (slime-repl-current-input)))
775 (goto-char (point-max))
776 (slime-mark-input-start)
777 (slime-mark-output-start)
778 (slime-repl-send-string input)))
779
780 (defun slime-repl-grab-old-input (replace)
781 "Resend the old REPL input at point.
782 If replace is non-nil the current input is replaced with the old
783 input; otherwise the new input is appended. The old input has the
784 text property `slime-repl-old-input'."
785 (multiple-value-bind (beg end) (slime-property-bounds 'slime-repl-old-input)
786 (let ((old-input (buffer-substring beg end)) ;;preserve
787 ;;properties, they will be removed later
788 (offset (- (point) beg)))
789 ;; Append the old input or replace the current input
790 (cond (replace (goto-char slime-repl-input-start-mark))
791 (t (goto-char (point-max))
792 (unless (eq (char-before) ?\ )
793 (insert " "))))
794 (delete-region (point) (point-max))
795 (save-excursion
796 (insert old-input)
797 (when (equal (char-before) ?\n)
798 (delete-char -1)))
799 (forward-char offset))))
800
801 (defun slime-repl-closing-return ()
802 "Evaluate the current input string after closing all open lists."
803 (interactive)
804 (goto-char (point-max))
805 (save-restriction
806 (narrow-to-region slime-repl-input-start-mark (point))
807 (while (ignore-errors (save-excursion (backward-up-list 1)) t)
808 (insert ")")))
809 (slime-repl-return))
810
811 (defun slime-repl-newline-and-indent ()
812 "Insert a newline, then indent the next line.
813 Restrict the buffer from the prompt for indentation, to avoid being
814 confused by strange characters (like unmatched quotes) appearing
815 earlier in the buffer."
816 (interactive)
817 (save-restriction
818 (narrow-to-region slime-repl-prompt-start-mark (point-max))
819 (insert "\n")
820 (lisp-indent-line)))
821
822 (defun slime-repl-delete-current-input ()
823 "Delete all text from the prompt."
824 (interactive)
825 (delete-region slime-repl-input-start-mark (point-max)))
826
827 (defun slime-eval-last-expression-in-repl (prefix)
828 "Evaluates last expression in the Slime REPL.
829
830 Switches REPL to current package of the source buffer for the duration. If
831 used with a prefix argument (C-u), doesn't switch back afterwards."
832 (interactive "P")
833 (let ((expr (slime-last-expression))
834 (buffer-name (buffer-name (current-buffer)))
835 (new-package (slime-current-package))
836 (old-package (slime-lisp-package))
837 (slime-repl-suppress-prompt t)
838 (yank-back nil))
839 (save-excursion
840 (set-buffer (slime-output-buffer))
841 (unless (eq (current-buffer) (window-buffer))
842 (pop-to-buffer (current-buffer) t))
843 (end-of-buffer)
844 ;; Kill pending input in the REPL
845 (when (< (marker-position slime-repl-input-start-mark) (point))
846 (kill-region slime-repl-input-start-mark (point))
847 (setq yank-back t))
848 (unwind-protect
849 (progn
850 (insert-before-markers (format "\n;;; from %s\n" buffer-name))
851 (when new-package
852 (slime-repl-set-package new-package))
853 (let ((slime-repl-suppress-prompt nil))
854 (slime-repl-insert-prompt))
855 (insert expr)
856 (slime-repl-return))
857 (unless (or prefix (equal (slime-lisp-package) old-package))
858 ;; Switch back.
859 (slime-repl-set-package old-package)
860 (let ((slime-repl-suppress-prompt nil))
861 (slime-repl-insert-prompt))))
862 ;; Put pending input back.
863 (when yank-back
864 (yank)))))
865
866 (defun slime-repl-kill-input ()
867 "Kill all text from the prompt to point."
868 (interactive)
869 (cond ((< (marker-position slime-repl-input-start-mark) (point))
870 (kill-region slime-repl-input-start-mark (point)))
871 ((= (point) (marker-position slime-repl-input-start-mark))
872 (slime-repl-delete-current-input))))
873
874 (defun slime-repl-replace-input (string)
875 (slime-repl-delete-current-input)
876 (insert-and-inherit string))
877
878 (defun slime-repl-input-line-beginning-position ()
879 (save-excursion
880 (goto-char slime-repl-input-start-mark)
881 (line-beginning-position)))
882
883 (defun slime-clear-repl-variables ()
884 (interactive)
885 (slime-eval-async `(swank:clear-repl-variables)))
886
887 (defvar slime-repl-clear-buffer-hook)
888
889 (add-hook 'slime-repl-clear-buffer-hook 'slime-clear-repl-variables)
890
891 (defun slime-repl-clear-buffer ()
892 "Delete the output generated by the Lisp process."
893 (interactive)
894 (let ((inhibit-read-only t))
895 (delete-region (point-min) slime-repl-prompt-start-mark)
896 (delete-region slime-output-start slime-output-end)
897 (when (< (point) slime-repl-input-start-mark)
898 (goto-char slime-repl-input-start-mark))
899 (recenter t))
900 (run-hooks 'slime-repl-clear-buffer-hook))
901
902 (defun slime-repl-clear-output ()
903 "Delete the output inserted since the last input."
904 (interactive)
905 (let ((start (save-excursion
906 (when (>= (point) slime-repl-input-start-mark)
907 (goto-char slime-repl-input-start-mark))
908 (slime-repl-previous-prompt)
909 (ignore-errors (forward-sexp))
910 (forward-line)
911 (point)))
912 (end (1- (slime-repl-input-line-beginning-position))))
913 (when (< start end)
914 (let ((inhibit-read-only t))
915 (delete-region start end)
916 (save-excursion
917 (goto-char start)
918 (insert ";;; output flushed"))))))
919
920 (defun slime-repl-set-package (package)
921 "Set the package of the REPL buffer to PACKAGE."
922 (interactive (list (let* ((p (slime-current-package))
923 (p (and p (slime-pretty-package-name p)))
924 (p (and (not (equal p (slime-lisp-package))) p)))
925 (slime-read-package-name "Package: " p))))
926 (with-current-buffer (slime-output-buffer)
927 (let ((previouse-point (- (point) slime-repl-input-start-mark))
928 (previous-prompt (slime-lisp-package-prompt-string)))
929 (destructuring-bind (name prompt-string)
930 (slime-repl-shortcut-eval `(swank:set-package ,package))
931 (setf (slime-lisp-package) name)
932 (setf slime-buffer-package name)
933 (unless (equal previous-prompt prompt-string)
934 (setf (slime-lisp-package-prompt-string) prompt-string)
935 (slime-repl-insert-prompt))
936 (when (plusp previouse-point)
937 (goto-char (+ previouse-point slime-repl-input-start-mark)))))))
938
939
940 ;;;;; History
941
942 (defcustom slime-repl-wrap-history nil
943 "*T to wrap history around when the end is reached."
944 :type 'boolean
945 :group 'slime-repl)
946
947 (defcustom slime-repl-history-remove-duplicates nil
948 "*When T all duplicates are removed except the last one."
949 :type 'boolean
950 :group 'slime-repl)
951
952 (defcustom slime-repl-history-trim-whitespaces nil
953 "*When T strip all whitespaces from the beginning and end."
954 :type 'boolean
955 :group 'slime-repl)
956
957 (make-variable-buffer-local
958 (defvar slime-repl-input-history '()
959 "History list of strings read from the REPL buffer."))
960
961 (defun slime-string-trim (character-bag string)
962 (flet ((find-bound (&optional from-end)
963 (position-if-not (lambda (char) (memq char character-bag))
964 string :from-end from-end)))
965 (let ((start (find-bound))
966 (end (find-bound t)))
967 (if start
968 (subseq string start (1+ end))
969 ""))))
970
971 (defun slime-repl-add-to-input-history (string)
972 "Add STRING to the input history.
973 Empty strings and duplicates are ignored."
974 (when slime-repl-history-trim-whitespaces
975 (setq string (slime-string-trim '(?\n ?\ ?\t) string)))
976 (unless (equal string "")
977 (when slime-repl-history-remove-duplicates
978 (setq slime-repl-input-history
979 (remove string slime-repl-input-history)))
980 (unless (equal string (car slime-repl-input-history))
981 (push string slime-repl-input-history))))
982
983 ;; These two vars contain the state of the last history search. We
984 ;; only use them if `last-command' was 'slime-repl-history-replace,
985 ;; otherwise we reinitialize them.
986
987 (defvar slime-repl-input-history-position -1
988 "Newer items have smaller indices.")
989
990 (defvar slime-repl-history-pattern nil
991 "The regexp most recently used for finding input history.")
992
993 (defun slime-repl-history-replace (direction &optional regexp)
994 "Replace the current input with the next line in DIRECTION.
995 DIRECTION is 'forward' or 'backward' (in the history list).
996 If REGEXP is non-nil, only lines matching REGEXP are considered."
997 (setq slime-repl-history-pattern regexp)
998 (let* ((min-pos -1)
999 (max-pos (length slime-repl-input-history))
1000 (pos0 (cond ((slime-repl-history-search-in-progress-p)
1001 slime-repl-input-history-position)
1002 (t min-pos)))
1003 (pos (slime-repl-position-in-history pos0 direction (or regexp "")
1004 (slime-repl-current-input)))
1005 (msg nil))
1006 (cond ((and (< min-pos pos) (< pos max-pos))
1007 (slime-repl-replace-input (nth pos slime-repl-input-history))
1008 (setq msg (format "History item: %d" pos)))
1009 ((not slime-repl-wrap-history)
1010 (setq msg (cond ((= pos min-pos) "End of history")
1011 ((= pos max-pos) "Beginning of history"))))
1012 (slime-repl-wrap-history
1013 (setq pos (if (= pos min-pos) max-pos min-pos))
1014 (setq msg "Wrapped history")))
1015 (when (or (<= pos min-pos) (<= max-pos pos))
1016 (when regexp
1017 (setq msg (concat msg "; no matching item"))))
1018 ;;(message "%s [%d %d %s]" msg start-pos pos regexp)
1019 (message "%s%s" msg (cond ((not regexp) "")
1020 (t (format "; current regexp: %s" regexp))))
1021 (setq slime-repl-input-history-position pos)
1022 (setq this-command 'slime-repl-history-replace)))
1023
1024 (defun slime-repl-history-search-in-progress-p ()
1025 (eq last-command 'slime-repl-history-replace))
1026
1027 (defun slime-repl-terminate-history-search ()
1028 (setq last-command this-command))
1029
1030 (defun slime-repl-position-in-history (start-pos direction regexp
1031 &optional exclude-string)
1032 "Return the position of the history item matching REGEXP.
1033 Return -1 resp. the length of the history if no item matches.
1034 If EXCLUDE-STRING is specified then it's excluded from the search."
1035 ;; Loop through the history list looking for a matching line
1036 (let* ((step (ecase direction
1037 (forward -1)
1038 (backward 1)))
1039 (history slime-repl-input-history)
1040 (len (length history)))
1041 (loop for pos = (+ start-pos step) then (+ pos step)
1042 if (< pos 0) return -1
1043 if (<= len pos) return len
1044 for history-item = (nth pos history)
1045 if (and (string-match regexp history-item)
1046 (not (equal history-item exclude-string)))
1047 return pos)))
1048
1049 (defun slime-repl-previous-input ()
1050 "Cycle backwards through input history.
1051 If the `last-command' was a history navigation command use the
1052 same search pattern for this command.
1053 Otherwise use the current input as search pattern."
1054 (interactive)
1055 (slime-repl-history-replace 'backward (slime-repl-history-pattern t)))
1056
1057 (defun slime-repl-next-input ()
1058 "Cycle forwards through input history.
1059 See `slime-repl-previous-input'."
1060 (interactive)
1061 (slime-repl-history-replace 'forward (slime-repl-history-pattern t)))
1062
1063 (defun slime-repl-forward-input ()
1064 "Cycle forwards through input history."
1065 (interactive)
1066 (slime-repl-history-replace 'forward (slime-repl-history-pattern)))
1067
1068 (defun slime-repl-backward-input ()
1069 "Cycle backwards through input history."
1070 (interactive)
1071 (slime-repl-history-replace 'backward (slime-repl-history-pattern)))
1072
1073 (defun slime-repl-previous-matching-input (regexp)
1074 (interactive (list (slime-read-from-minibuffer
1075 "Previous element matching (regexp): ")))
1076 (slime-repl-terminate-history-search)
1077 (slime-repl-history-replace 'backward regexp))
1078
1079 (defun slime-repl-next-matching-input (regexp)
1080 (interactive (list (slime-read-from-minibuffer
1081 "Next element matching (regexp): ")))
1082 (slime-repl-terminate-history-search)
1083 (slime-repl-history-replace 'forward regexp))
1084
1085 (defun slime-repl-history-pattern (&optional use-current-input)
1086 "Return the regexp for the navigation commands."
1087 (cond ((slime-repl-history-search-in-progress-p)
1088 slime-repl-history-pattern)
1089 (use-current-input
1090 (assert (<= slime-repl-input-start-mark (point)))
1091 (let ((str (slime-repl-current-input t)))
1092 (cond ((string-match "^[ \t\n]*$" str) nil)
1093 (t (concat "^" (regexp-quote str))))))
1094 (t nil)))
1095
1096 (defun slime-repl-delete-from-input-history (string)
1097 "Delete STRING from the repl input history.
1098
1099 When string is not provided then clear the current repl input and
1100 use it as an input. This is useful to get rid of unwanted repl
1101 history entries while navigating the repl history."
1102 (interactive (list (slime-repl-current-input)))
1103 (let ((merged-history
1104 (slime-repl-merge-histories slime-repl-input-history
1105 (slime-repl-read-history nil t))))
1106 (setq slime-repl-input-history
1107 (delete* string merged-history :test #'string=))
1108 (slime-repl-save-history))
1109 (slime-repl-delete-current-input))
1110
1111 ;;;;; Persistent History
1112
1113 (defun slime-repl-merge-histories (old-hist new-hist)
1114 "Merge entries from OLD-HIST and NEW-HIST."
1115 ;; Newer items in each list are at the beginning.
1116 (let* ((ht (make-hash-table :test #'equal))
1117 (test (lambda (entry)
1118 (or (gethash entry ht)
1119 (progn (setf (gethash entry ht) t)
1120 nil)))))
1121 (append (remove-if test new-hist)
1122 (remove-if test old-hist))))
1123
1124 (defun slime-repl-load-history (&optional filename)
1125 "Set the current SLIME REPL history.
1126 It can be read either from FILENAME or `slime-repl-history-file' or
1127 from a user defined filename."
1128 (interactive (list (slime-repl-read-history-filename)))
1129 (let ((file (or filename slime-repl-history-file)))
1130 (setq slime-repl-input-history (slime-repl-read-history file t))))
1131
1132 (defun slime-repl-read-history (&optional filename noerrer)
1133 "Read and return the history from FILENAME.
1134 The default value for FILENAME is `slime-repl-history-file'.
1135 If NOERROR is true return and the file doesn't exits return nil."
1136 (let ((file (or filename slime-repl-history-file)))
1137 (cond ((not (file-readable-p file)) '())
1138 (t (with-temp-buffer
1139 (insert-file-contents file)
1140 (read (current-buffer)))))))
1141
1142 (defun slime-repl-read-history-filename ()
1143 (read-file-name "Use SLIME REPL history from file: "
1144 slime-repl-history-file))
1145
1146 (defun slime-repl-save-merged-history (&optional filename)
1147 "Read the history file, merge the current REPL history and save it.
1148 This tries to be smart in merging the history from the file and the
1149 current history in that it tries to detect the unique entries using
1150 `slime-repl-merge-histories'."
1151 (interactive (list (slime-repl-read-history-filename)))
1152 (let ((file (or filename slime-repl-history-file)))
1153 (with-temp-message "saving history..."
1154 (let ((hist (slime-repl-merge-histories (slime-repl-read-history file t)
1155 slime-repl-input-history)))
1156 (slime-repl-save-history file hist)))))
1157
1158 (defun slime-repl-save-history (&optional filename history)
1159 "Simply save the current SLIME REPL history to a file.
1160 When SLIME is setup to always load the old history and one uses only
1161 one instance of slime all the time, there is no need to merge the
1162 files and this function is sufficient.
1163
1164 When the list is longer than `slime-repl-history-size' it will be
1165 truncated. That part is untested, though!"
1166 (interactive (list (slime-repl-read-history-filename)))
1167 (let ((file (or filename slime-repl-history-file))
1168 (hist (or history slime-repl-input-history)))
1169 (unless (file-writable-p file)
1170 (error (format "History file not writable: %s" file)))
1171 (let ((hist (subseq hist 0 (min (length hist) slime-repl-history-size))))
1172 ;;(message "saving %s to %s\n" hist file)
1173 (with-temp-file file
1174 (let ((cs slime-repl-history-file-coding-system)
1175 (print-length nil) (print-level nil))
1176 (setq buffer-file-coding-system cs)
1177 (insert (format ";; -*- coding: %s -*-\n" cs))
1178 (insert ";; History for SLIME REPL. Automatically written.\n"
1179 ";; Edit only if you know what you're doing\n")
1180 (prin1 (mapcar #'substring-no-properties hist) (current-buffer)))))))
1181
1182 (defun slime-repl-save-all-histories ()
1183 "Save the history in each repl buffer."
1184 (dolist (b (buffer-list))
1185 (with-current-buffer b
1186 (when (eq major-mode 'slime-repl-mode)
1187 (slime-repl-safe-save-merged-history)))))
1188
1189 (defun slime-repl-safe-save-merged-history ()
1190 (slime-repl-call-with-handler
1191 #'slime-repl-save-merged-history
1192 "%S while saving the history. Continue? "))
1193
1194 (defun slime-repl-safe-load-history ()
1195 (slime-repl-call-with-handler
1196 #'slime-repl-load-history
1197 "%S while loading the history. Continue? "))
1198
1199 (defun slime-repl-call-with-handler (fun query)
1200 "Call FUN in the context of an error handler.
1201 The handler will use qeuery to ask the use if the error should be ingored."
1202 (condition-case err
1203 (funcall fun)
1204 (error
1205 (if (y-or-n-p (format query (error-message-string err)))
1206 nil
1207 (signal (car err) (cdr err))))))
1208
1209
1210 ;;;;; REPL Read Mode
1211
1212 (define-key slime-repl-mode-map
1213 (string slime-repl-shortcut-dispatch-char) 'slime-handle-repl-shortcut)
1214
1215 (define-minor-mode slime-repl-read-mode
1216 "Mode the read input from Emacs
1217 \\{slime-repl-read-mode-map}"
1218 nil
1219 "[read]"
1220 '(("\C-m" . slime-repl-return)
1221 ([return] . slime-repl-return)
1222 ("\C-c\C-b" . slime-repl-read-break)
1223 ("\C-c\C-c" . slime-repl-read-break)))
1224
1225 (make-variable-buffer-local
1226 (defvar slime-read-string-threads nil))
1227
1228 (make-variable-buffer-local
1229 (defvar slime-read-string-tags nil))
1230
1231 (defun slime-repl-read-string (thread tag)
1232 (slime-switch-to-output-buffer)
1233 (push thread slime-read-string-threads)
1234 (push tag slime-read-string-tags)
1235 (goto-char (point-max))
1236 (slime-mark-output-end)
1237 (slime-mark-input-start)
1238 (slime-repl-read-mode 1))
1239
1240 (defun slime-repl-return-string (string)
1241 (slime-dispatch-event `(:emacs-return-string
1242 ,(pop slime-read-string-threads)
1243 ,(pop slime-read-string-tags)
1244 ,string))
1245 (slime-repl-read-mode -1))
1246
1247 (defun slime-repl-read-break ()
1248 (interactive)
1249 (slime-dispatch-event `(:emacs-interrupt ,(car slime-read-string-threads))))
1250
1251 (defun slime-repl-abort-read (thread tag)
1252 (with-current-buffer (slime-output-buffer)
1253 (pop slime-read-string-threads)
1254 (pop slime-read-string-tags)
1255 (slime-repl-read-mode -1)
1256 (message "Read aborted")))
1257
1258
1259 ;;;;; REPL handlers
1260
1261 (defstruct (slime-repl-shortcut (:conc-name slime-repl-shortcut.))
1262 symbol names handler one-liner)
1263
1264 (defvar slime-repl-shortcut-table nil
1265 "A list of slime-repl-shortcuts")
1266
1267 (defvar slime-repl-shortcut-history '()
1268 "History list of shortcut command names.")
1269
1270 (defvar slime-within-repl-shortcut-handler-p nil
1271 "Bound to T if we're in a REPL shortcut handler invoked from the REPL.")
1272
1273 (defun slime-handle-repl-shortcut ()
1274 (interactive)
1275 (if (> (point) slime-repl-input-start-mark)
1276 (insert (string slime-repl-shortcut-dispatch-char))
1277 (let ((shortcut (slime-lookup-shortcut
1278 (completing-read "Command: "
1279 (slime-bogus-completion-alist
1280 (slime-list-all-repl-shortcuts))
1281 nil t nil
1282 'slime-repl-shortcut-history))))
1283 (with-struct (slime-repl-shortcut. handler) shortcut
1284 (let ((slime-within-repl-shortcut-handler-p t))
1285 (call-interactively handler))))))
1286
1287 (defun slime-list-all-repl-shortcuts ()
1288 (loop for shortcut in slime-repl-shortcut-table
1289 append (slime-repl-shortcut.names shortcut)))
1290
1291 (defun slime-lookup-shortcut (name)
1292 (find-if (lambda (s) (member name (slime-repl-shortcut.names s)))
1293 slime-repl-shortcut-table))
1294
1295 (defmacro defslime-repl-shortcut (elisp-name names &rest options)
1296 "Define a new repl shortcut. ELISP-NAME is a symbol specifying
1297 the name of the interactive function to create, or NIL if no
1298 function should be created.
1299
1300 NAMES is a list of \(full-name . aliases\).
1301
1302 OPTIONS is an plist specifying the handler doing the actual work
1303 of the shortcut \(`:handler'\), and a help text \(`:one-liner'\)."
1304 `(progn
1305 ,(when elisp-name
1306 `(defun ,elisp-name ()
1307 (interactive)
1308 (call-interactively ,(second (assoc :handler options)))))
1309 (let ((new-shortcut (make-slime-repl-shortcut
1310 :symbol ',elisp-name
1311 :names (list ,@names)
1312 ,@(apply #'append options))))
1313 (setq slime-repl-shortcut-table
1314 (remove-if (lambda (s)
1315 (member ',(car names) (slime-repl-shortcut.names s)))
1316 slime-repl-shortcut-table))
1317 (push new-shortcut slime-repl-shortcut-table)
1318 ',elisp-name)))
1319
1320 (defun slime-repl-shortcut-eval (sexp &optional package)
1321 "This function should be used by REPL shortcut handlers instead
1322 of `slime-eval' to evaluate their final expansion. (This
1323 expansion will be added to the REPL's history.)"
1324 (when slime-within-repl-shortcut-handler-p ; were we invoked via ,foo?
1325 (slime-repl-add-to-input-history (prin1-to-string sexp)))
1326 (slime-eval sexp package))
1327
1328 (defun slime-repl-shortcut-eval-async (sexp &optional cont package)
1329 "This function should be used by REPL shortcut handlers instead
1330 of `slime-eval-async' to evaluate their final expansion. (This
1331 expansion will be added to the REPL's history.)"
1332 (when slime-within-repl-shortcut-handler-p ; were we invoked via ,foo?
1333 (slime-repl-add-to-input-history (prin1-to-string sexp)))
1334 (slime-eval-async sexp cont package))
1335
1336 (defun slime-list-repl-short-cuts ()
1337 (interactive)
1338 (slime-with-popup-buffer ((slime-buffer-name :repl-help))
1339 (let ((table (sort* (copy-list slime-repl-shortcut-table) #'string<
1340 :key (lambda (x)
1341 (car (slime-repl-shortcut.names x))))))
1342 (save-excursion
1343 (dolist (shortcut table)
1344 (let ((names (slime-repl-shortcut.names shortcut)))
1345 (insert (pop names)) ;; first print the "full" name
1346 (when names
1347 ;; we also have aliases
1348 (insert " (aka ")
1349 (while (cdr names)
1350 (insert (pop names) ", "))
1351 (insert (car names) ")"))
1352 (when (slime-repl-shortcut.one-liner shortcut)
1353 (insert "\n " (slime-repl-shortcut.one-liner shortcut)))
1354 (insert "\n")))))))
1355
1356 (defun slime-save-some-lisp-buffers ()
1357 (if slime-repl-only-save-lisp-buffers
1358 (save-some-buffers nil (lambda ()
1359 (and (memq major-mode slime-lisp-modes)
1360 (not (null buffer-file-name)))))
1361 (save-some-buffers)))
1362
1363 (defslime-repl-shortcut slime-repl-shortcut-help ("help")
1364 (:handler 'slime-list-repl-short-cuts)
1365 (:one-liner "Display the help."))
1366
1367 (defslime-repl-shortcut nil ("change-directory" "!d" "cd")
1368 (:handler 'slime-set-default-directory)
1369 (:one-liner "Change the current directory."))
1370
1371 (defslime-repl-shortcut nil ("pwd")
1372 (:handler (lambda ()
1373 (interactive)
1374 (let ((dir (slime-eval `(swank:default-directory))))
1375 (message "Directory %s" dir))))
1376 (:one-liner "Show the current directory."))
1377
1378 (defslime-repl-shortcut slime-repl-push-directory
1379 ("push-directory" "+d" "pushd")
1380 (:handler (lambda (directory)
1381 (interactive
1382 (list (read-directory-name
1383 "Push directory: "
1384 (slime-eval '(swank:default-directory))
1385 nil nil "")))
1386 (push (slime-eval '(swank:default-directory))
1387 slime-repl-directory-stack)
1388 (slime-set-default-directory directory)))
1389 (:one-liner "Save the current directory and set it to a new one."))
1390
1391 (defslime-repl-shortcut slime-repl-pop-directory
1392 ("pop-directory" "-d" "popd")
1393 (:handler (lambda ()
1394 (interactive)
1395 (if (null slime-repl-directory-stack)
1396 (message "Directory stack is empty.")
1397 (slime-set-default-directory
1398 (pop slime-repl-directory-stack)))))
1399 (:one-liner "Restore the last saved directory."))
1400
1401 (defslime-repl-shortcut nil ("change-package" "!p" "in-package" "in")
1402 (:handler 'slime-repl-set-package)
1403 (:one-liner "Change the current package."))
1404
1405 (defslime-repl-shortcut slime-repl-push-package ("push-package" "+p")
1406 (:handler (lambda (package)
1407 (interactive (list (slime-read-package-name "Package: ")))
1408 (push (slime-lisp-package) slime-repl-package-stack)
1409 (slime-repl-set-package package)))
1410 (:one-liner "Save the current package and set it to a new one."))
1411
1412 (defslime-repl-shortcut slime-repl-pop-package ("pop-package" "-p")
1413 (:handler (lambda ()
1414 (interactive)
1415 (if (null slime-repl-package-stack)
1416 (message "Package stack is empty.")
1417 (slime-repl-set-package
1418 (pop slime-repl-package-stack)))))
1419 (:one-liner "Restore the last saved package."))
1420
1421 (defslime-repl-shortcut slime-repl-resend ("resend-form")
1422 (:handler (lambda ()
1423 (interactive)
1424 (insert (car slime-repl-input-history))
1425 (insert "\n")
1426 (slime-repl-send-input)))
1427 (:one-liner "Resend the last form."))
1428
1429 (defslime-repl-shortcut slime-repl-disconnect ("disconnect")
1430 (:handler 'slime-disconnect)
1431 (:one-liner "Disconnect the current connection."))
1432
1433 (defslime-repl-shortcut slime-repl-disconnect-all ("disconnect-all")
1434 (:handler 'slime-disconnect-all)
1435 (:one-liner "Disconnect all connections."))
1436
1437 (defslime-repl-shortcut slime-repl-sayoonara ("sayoonara")
1438 (:handler (lambda ()
1439 (interactive)
1440 (when (slime-connected-p)
1441 (slime-quit-lisp))
1442 (slime-kill-all-buffers)))
1443 (:one-liner "Quit all Lisps and close all SLIME buffers."))
1444
1445 (defslime-repl-shortcut slime-repl-quit ("quit")
1446 (:handler (lambda ()
1447 (interactive)
1448 ;; `slime-quit-lisp' determines the connection to quit
1449 ;; on behalf of the REPL's `slime-buffer-connection'.
1450 (let ((repl-buffer (slime-output-buffer)))
1451 (slime-quit-lisp)
1452 (kill-buffer repl-buffer))))
1453 (:one-liner "Quit the current Lisp."))
1454
1455 (defslime-repl-shortcut slime-repl-defparameter ("defparameter" "!")
1456 (:handler (lambda (name value)
1457 (interactive (list (slime-read-symbol-name "Name (symbol): " t)
1458 (slime-read-from-minibuffer "Value: " "*")))
1459 (insert "(cl:defparameter " name " " value
1460 " \"REPL generated global variable.\")")
1461 (slime-repl-send-input t)))
1462 (:one-liner "Define a new global, special, variable."))
1463
1464 (defslime-repl-shortcut slime-repl-compile-and-load ("compile-and-load" "cl")
1465 (:handler (lambda (filename)
1466 (interactive (list (expand-file-name
1467 (read-file-name "File: " nil nil nil nil))))
1468 (slime-save-some-lisp-buffers)
1469 (slime-repl-shortcut-eval-async
1470 `(swank:compile-file-if-needed
1471 ,(slime-to-lisp-filename filename) t)
1472 #'slime-compilation-finished)))
1473 (:one-liner "Compile (if neccessary) and load a lisp file."))
1474
1475 (defslime-repl-shortcut nil ("restart-inferior-lisp")
1476 (:handler 'slime-restart-inferior-lisp)
1477 (:one-liner "Restart *inferior-lisp* and reconnect SLIME."))
1478
1479 (defun slime-redirect-inferior-output (&optional noerror)
1480 "Redirect output of the inferior-process to the REPL buffer."
1481 (interactive)
1482 (let ((proc (slime-inferior-process)))
1483 (cond (proc
1484 (let ((filter (slime-rcurry #'slime-inferior-output-filter
1485 (slime-current-connection))))
1486 (set-process-filter proc filter)))
1487 (noerror)
1488 (t (error "No inferior lisp process")))))
1489
1490 (defun slime-inferior-output-filter (proc string conn)
1491 (cond ((eq (process-status conn) 'closed)
1492 (message "Connection closed. Removing inferior output filter.")
1493 (message "Lost output: %S" string)
1494 (set-process-filter proc nil))
1495 (t
1496 (slime-output-filter conn string))))
1497
1498 (defun slime-redirect-trace-output ()
1499 "Redirect the trace output to a separate Emacs buffer."
1500 (interactive)
1501 (let ((buffer (get-buffer-create (slime-buffer-name :trace))))
1502 (with-current-buffer buffer
1503 (let ((marker (copy-marker (buffer-size)))
1504 (target (incf slime-last-output-target-id)))
1505 (puthash target marker slime-output-target-to-marker)
1506 (slime-eval `(swank:redirect-trace-output ,target))))
1507 ;; Note: We would like the entries in
1508 ;; slime-output-target-to-marker to disappear when the buffers are
1509 ;; killed. We cannot just make the hash-table ":weakness 'value"
1510 ;; -- there is no reference from the buffers to the markers in the
1511 ;; buffer, so entries would disappear even though the buffers are
1512 ;; alive. Best solution might be to make buffer-local variables
1513 ;; that keep the markers. --mkoeppe
1514 (pop-to-buffer buffer)))
1515
1516 (defun slime-call-defun ()
1517 "Insert a call to the toplevel form defined around point into the REPL."
1518 (interactive)
1519 (flet ((insert-call (name &key (function t)
1520 defclass)
1521 (let* ((setf (and function
1522 (consp name)
1523 (= (length name) 2)
1524 (eql (car name) 'setf)))
1525 (symbol (if setf
1526 (cadr name)
1527 name))
1528 (qualified-symbol-name (slime-qualify-cl-symbol-name symbol))
1529 (symbol-name (slime-cl-symbol-name qualified-symbol-name))
1530 (symbol-package (slime-cl-symbol-package
1531 qualified-symbol-name))
1532 (call (if (equalp (slime-lisp-package) symbol-package)
1533 symbol-name
1534 qualified-symbol-name)))
1535 (slime-switch-to-output-buffer)
1536 (goto-char slime-repl-input-start-mark)
1537 (insert (if function
1538 "("
1539 " "))
1540 (when setf
1541 (insert "setf ("))
1542 (if defclass
1543 (insert "make-instance '"))
1544 (insert call)
1545 (cond (setf
1546 (insert " ")
1547 (save-excursion (insert ") )")))
1548 (function
1549 (insert " ")
1550 (save-excursion (insert ")"))))
1551 (unless function
1552 (goto-char slime-repl-input-start-mark)))))
1553 (let ((toplevel (slime-parse-toplevel-form)))
1554 (if (symbolp toplevel)
1555 (error "Not in a function definition")
1556 (destructure-case toplevel
1557 (((:defun :defgeneric :defmacro :define-compiler-macro) symbol)
1558 (insert-call symbol))
1559 ((:defmethod symbol &rest args)
1560 (declare (ignore args))
1561 (insert-call symbol))
1562 (((:defparameter :defvar :defconstant) symbol)
1563 (insert-call symbol :function nil))
1564 (((:defclass) symbol)
1565 (insert-call symbol :defclass t))
1566 (t
1567 (error "Not in a function definition")))))))
1568
1569 (defun slime-inspector-copy-down-to-repl (number)
1570 "Evaluate the inspector slot at point via the REPL (to set `*')."
1571 (interactive (list (or (get-text-property (point) 'slime-part-number)
1572 (error "No part at point"))))
1573 (slime-repl-send-string (format "%s" `(swank:inspector-nth-part ,number)))
1574 (slime-repl))
1575
1576 (defun sldb-insert-frame-call-to-repl ()
1577 "Insert a call to a frame at point."
1578 (interactive)
1579 (let ((call (slime-eval `(swank-backend::frame-call
1580 ,(sldb-frame-number-at-point)))))
1581 (slime-switch-to-output-buffer)
1582 (if (>= (point) slime-repl-prompt-start-mark)
1583 (insert call)
1584 (save-excursion
1585 (goto-char (point-max))
1586 (insert call))))
1587 (slime-repl))
1588
1589 (defun slime-set-default-directory (directory)
1590 "Make DIRECTORY become Lisp's current directory."
1591 (interactive (list (read-directory-name "Directory: " nil nil t)))
1592 (let ((dir (expand-file-name directory)))
1593 (message "default-directory: %s"
1594 (slime-from-lisp-filename
1595 (slime-repl-shortcut-eval `(swank:set-default-directory
1596 ,(slime-to-lisp-filename dir)))))
1597 (with-current-buffer (slime-output-buffer)
1598 (setq default-directory dir))))
1599
1600 (defun slime-sync-package-and-default-directory ()
1601 "Set Lisp's package and directory to the values in current buffer."
1602 (interactive)
1603 (let* ((package (slime-current-package))
1604 (exists-p (or (null package)
1605 (slime-eval `(cl:packagep
1606 (swank::guess-package ,package)))))
1607 (directory default-directory))
1608 (when (and package exists-p)
1609 (slime-repl-set-package package))
1610 (slime-set-default-directory directory)
1611 ;; Sync *inferior-lisp* dir
1612 (let* ((proc (slime-process))
1613 (buffer (and proc (process-buffer proc))))
1614 (when buffer
1615 (with-current-buffer buffer
1616 (setq default-directory directory))))
1617 (message "package: %s%s directory: %s"
1618 (with-current-buffer (slime-output-buffer)
1619 (slime-lisp-package))
1620 (if exists-p "" (format " (package %s doesn't exist)" package))
1621 directory)))
1622
1623 (defun slime-goto-connection ()
1624 "Switch to the REPL buffer for the connection at point."
1625 (interactive)
1626 (let ((slime-dispatching-connection (slime-connection-at-point)))
1627 (switch-to-buffer (slime-output-buffer))))
1628
1629 (defun slime-repl-inside-string-or-comment-p ()
1630 (save-restriction
1631 (when (and (boundp 'slime-repl-input-start-mark)
1632 slime-repl-input-start-mark
1633 (>= (point) slime-repl-input-start-mark))
1634 (narrow-to-region slime-repl-input-start-mark (point)))
1635 (slime-inside-string-or-comment-p)))
1636
1637 (defvar slime-repl-easy-menu
1638 (let ((C '(slime-connected-p)))
1639 `("REPL"
1640 [ "Send Input" slime-repl-return ,C ]
1641 [ "Close and Send Input " slime-repl-closing-return ,C ]
1642 [ "Interrupt Lisp process" slime-interrupt ,C ]
1643 "--"
1644 [ "Previous Input" slime-repl-previous-input t ]
1645 [ "Next Input" slime-repl-next-input t ]
1646 [ "Goto Previous Prompt " slime-repl-previous-prompt t ]
1647 [ "Goto Next Prompt " slime-repl-next-prompt t ]
1648 [ "Clear Last Output" slime-repl-clear-output t ]
1649 [ "Clear Buffer " slime-repl-clear-buffer t ]
1650 [ "Kill Current Input" slime-repl-kill-input t ])))
1651
1652 (defun slime-repl-add-easy-menu ()
1653 (easy-menu-define menubar-slime-repl slime-repl-mode-map
1654 "REPL" slime-repl-easy-menu)
1655 (easy-menu-define menubar-slime slime-repl-mode-map
1656 "SLIME" slime-easy-menu)
1657 (easy-menu-add slime-repl-easy-menu 'slime-repl-mode-map))
1658
1659 (add-hook 'slime-repl-mode-hook 'slime-repl-add-easy-menu)
1660
1661 (defun slime-hide-inferior-lisp-buffer ()
1662 "Display the REPL buffer instead of the *inferior-lisp* buffer."
1663 (let* ((buffer (if (slime-process)
1664 (process-buffer (slime-process))))
1665 (window (if buffer (get-buffer-window buffer t)))
1666 (repl-buffer (slime-output-buffer t))
1667 (repl-window (get-buffer-window repl-buffer)))
1668 (when buffer
1669 (bury-buffer buffer))
1670 (cond (repl-window
1671 (when window
1672 (delete-window window)))
1673 (window
1674 (set-window-buffer window repl-buffer))
1675 (t
1676 (pop-to-buffer repl-buffer)
1677 (goto-char (point-max))))))
1678
1679 (defun slime-repl-choose-coding-system ()
1680 (let ((candidates (slime-connection-coding-systems)))
1681 (or (find (symbol-name (car default-process-coding-system))
1682 candidates
1683 :test (lambda (s1 s2)
1684 (if (fboundp 'coding-system-equal)
1685 (coding-system-equal (intern s1) (intern s2)))))
1686 (car candidates)
1687 (error "Can't find suitable coding-system"))))
1688
1689 (defun slime-repl-connected-hook-function ()
1690 (destructuring-bind (package prompt)
1691 (let ((slime-current-thread t)
1692 (cs (slime-repl-choose-coding-system)))
1693 (slime-eval `(swank:create-repl nil :coding-system ,cs)))
1694 (setf (slime-lisp-package) package)
1695 (setf (slime-lisp-package-prompt-string) prompt))
1696 (slime-hide-inferior-lisp-buffer)
1697 (slime-init-output-buffer (slime-connection)))
1698
1699 (defun slime-repl-event-hook-function (event)
1700 (destructure-case event
1701 ((:write-string output &optional target)
1702 (slime-write-string output target)
1703 t)
1704 ((:read-string thread tag)
1705 (assert thread)
1706 (slime-repl-read-string thread tag)
1707 t)
1708 ((:read-aborted thread tag)
1709 (slime-repl-abort-read thread tag)
1710 t)
1711 ((:open-dedicated-output-stream port coding-system)
1712 (slime-open-stream-to-lisp port coding-system)
1713 t)
1714 ((:new-package package prompt-string)
1715 (setf (slime-lisp-package) package)
1716 (setf (slime-lisp-package-prompt-string) prompt-string)
1717 (let ((buffer (slime-connection-output-buffer)))
1718 (when (buffer-live-p buffer)
1719 (with-current-buffer buffer
1720 (setq slime-buffer-package package))))
1721 t)
1722 (t nil)))
1723
1724 (defun slime-change-repl-to-default-connection ()
1725 "Change current REPL to the REPL of the default connection.
1726 If the current buffer is not a REPL, don't do anything."
1727 (when (equal major-mode 'slime-repl-mode)
1728 (let ((slime-buffer-connection slime-default-connection))
1729 (pop-to-buffer-same-window (slime-connection-output-buffer)))))
1730
1731 (defun slime-repl-find-buffer-package ()
1732 (or (slime-search-buffer-package)
1733 (slime-lisp-package)))
1734
1735 (defun slime-repl-add-hooks ()
1736 (add-hook 'slime-event-hooks 'slime-repl-event-hook-function)
1737 (add-hook 'slime-connected-hook 'slime-repl-connected-hook-function)
1738 (add-hook 'slime-cycle-connections-hook
1739 'slime-change-repl-to-default-connection))
1740
1741 (defun slime-repl-remove-hooks ()
1742 (remove-hook 'slime-event-hooks 'slime-repl-event-hook-function)
1743 (remove-hook 'slime-connected-hook 'slime-repl-connected-hook-function)
1744 (remove-hook 'slime-cycle-connections-hook
1745 'slime-change-repl-to-default-connection))
1746
1747 (defun slime-repl-sexp-at-point ()
1748 "Returns the current sexp at point (or NIL if none is found)
1749 while ignoring the repl prompt text."
1750 (if (<= slime-repl-input-start-mark (point))
1751 (save-restriction
1752 (narrow-to-region slime-repl-input-start-mark (point-max))
1753 (slime-sexp-at-point))
1754 (slime-sexp-at-point)))
1755
1756 (defun slime-repl-inspect (string)
1757 (interactive
1758 (list (slime-read-from-minibuffer "Inspect value (evaluated): "
1759 (slime-repl-sexp-at-point))))
1760 (slime-inspect string))
1761
1762 (let ((byte-compile-warnings '()))
1763 (mapc #'byte-compile
1764 '(slime-repl-event-hook-function
1765 slime-write-string
1766 slime-repl-write-string
1767 slime-repl-emit
1768 slime-repl-show-maximum-output)))
1769
1770
1771 ;;; Tests
1772
1773 (def-slime-test package-updating
1774 (package-name nicknames)
1775 "Test if slime-lisp-package is updated."
1776 '(("COMMON-LISP" ("CL"))
1777 ("KEYWORD" ("" "KEYWORD" "||"))
1778 ("COMMON-LISP-USER" ("CL-USER")))
1779 (with-current-buffer (slime-output-buffer)
1780 (let ((p (slime-eval
1781 `(swank:listener-eval
1782 ,(format
1783 "(cl:setq cl:*print-case* :upcase)
1784 (cl:setq cl:*package* (cl:find-package %S))
1785 (cl:package-name cl:*package*)" package-name))
1786 (slime-lisp-package))))
1787 (slime-check ("slime-lisp-package is %S." package-name)
1788 (equal (slime-lisp-package) package-name))
1789 (slime-check ("slime-lisp-package-prompt-string is in %S." nicknames)
1790 (member (slime-lisp-package-prompt-string) nicknames)))))
1791
1792 (defmacro with-canonicalized-slime-repl-buffer (&rest body)
1793 "Evaluate BODY within a fresh REPL buffer. The REPL prompt is
1794 canonicalized to \"SWANK\"---we do actually switch to that
1795 package, though."
1796 `(let ((%old-prompt% (slime-lisp-package-prompt-string)))
1797 (unwind-protect
1798 (progn (with-current-buffer (slime-output-buffer)
1799 (setf (slime-lisp-package-prompt-string) "SWANK"))
1800 (kill-buffer (slime-output-buffer))
1801 (with-current-buffer (slime-output-buffer)
1802 ,@body))
1803 (setf (slime-lisp-package-prompt-string) %old-prompt%))))
1804
1805 (put 'with-canonicalized-slime-repl-buffer 'lisp-indent-function 0)
1806
1807 (def-slime-test repl-test
1808 (input result-contents)
1809 "Test simple commands in the minibuffer."
1810 '(("(+ 1 2)" "SWANK> (+ 1 2)
1811 {}3
1812 SWANK> *[]")
1813 ("(princ 10)" "SWANK> (princ 10)
1814 {10
1815 }10
1816 SWANK> *[]")
1817 ("(princ 10)(princ 20)" "SWANK> (princ 10)(princ 20)
1818 {1020
1819 }20
1820 SWANK> *[]")
1821 ("(dotimes (i 10 77) (princ i) (terpri))"
1822 "SWANK> (dotimes (i 10 77) (princ i) (terpri))
1823 {0
1824 1
1825 2
1826 3
1827 4
1828 5
1829 6
1830 7
1831 8
1832 9
1833 }77
1834 SWANK> *[]")
1835 ("(abort)" "SWANK> (abort)
1836 {}; Evaluation aborted.
1837 SWANK> *[]")
1838 ("(progn (princ 10) (force-output) (abort))"
1839 "SWANK> (progn (princ 10) (force-output) (abort))
1840 {10}; Evaluation aborted.
1841 SWANK> *[]")
1842 ("(progn (princ 10) (abort))"
1843 ;; output can be flushed after aborting
1844 "SWANK> (progn (princ 10) (abort))
1845 {10}; Evaluation aborted.
1846 SWANK> *[]")
1847 ("(if (fresh-line) 1 0)"
1848 "SWANK> (if (fresh-line) 1 0)
1849 {
1850 }1
1851 SWANK> *[]")
1852 ("(values 1 2 3)" "SWANK> (values 1 2 3)
1853 {}1
1854 2
1855 3
1856 SWANK> *[]")
1857 ("(with-standard-io-syntax
1858 (write (make-list 15 :initial-element '(1 . 2)) :pretty t) 0)"
1859 "SWANK> (with-standard-io-syntax
1860 (write (make-list 15 :initial-element '(1 . 2)) :pretty t) 0)
1861 {((1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2)
1862 (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2))
1863 }0
1864 SWANK> *[]")
1865 ;; Two times to test the effect of FRESH-LINE.
1866 ("(with-standard-io-syntax
1867 (write (make-list 15 :initial-element '(1 . 2)) :pretty t) 0)"
1868 "SWANK> (with-standard-io-syntax
1869 (write (make-list 15 :initial-element '(1 . 2)) :pretty t) 0)
1870 {((1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2)
1871 (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2) (1 . 2))
1872 }0
1873 SWANK> *[]"))
1874 (with-canonicalized-slime-repl-buffer
1875 (insert input)
1876 (slime-check-buffer-contents "Buffer contains input"
1877 (concat "{}SWANK> [" input "*]"))
1878 (call-interactively 'slime-repl-return)
1879 (slime-sync-to-top-level 5)
1880 (slime-check-buffer-contents "Buffer contains result" result-contents)))
1881
1882 (defun slime-check-buffer-contents (msg expected)
1883 (let* ((marks '((point . ?*)
1884 (slime-output-start . ?{) (slime-output-end . ?})
1885 (slime-repl-input-start-mark . ?\[) (point-max . ?\])))
1886 (marks (remove-if-not (lambda (m) (position (cdr m) expected))
1887 marks))
1888 (marks (sort (copy-sequence marks)
1889 (lambda (x y)
1890 (< (position (cdr x) expected)
1891 (position (cdr y) expected)))))
1892 (content (remove-if (lambda (c) (member* c marks :key #'cdr))
1893 expected))
1894 (marks (do ((result '() (acons (caar m) (1+ (position (cdar m) s))
1895 result))
1896 (m marks (cdr m))
1897 (s expected (remove* (cdar m) s)))
1898 ((null m) (reverse result))))
1899 (point (point))
1900 (point-max (point-max)))
1901 (slime-test-expect (concat msg " [content]") content (buffer-string))
1902 (macrolet ((test-mark
1903 (mark)
1904 `(when (assoc ',mark marks)
1905 (slime-test-expect (format "%s [%s]" msg ',mark)
1906 (cdr (assoc ',mark marks))
1907 ,mark
1908 #'=))))
1909 (test-mark point)
1910 (test-mark slime-output-end)
1911 (test-mark slime-output-start)
1912 (test-mark slime-repl-input-start-mark)
1913 (test-mark point-max))))
1914
1915 (def-slime-test repl-return
1916 (before after result-contents)
1917 "Test if slime-repl-return sends the correct protion to Lisp even
1918 if point is not at the end of the line."
1919 '(("(+ 1 2)" "" "SWANK> (+ 1 2)
1920 3
1921 SWANK> ")
1922 ("(+ 1 " "2)" "SWANK> (+ 1 2)
1923 3
1924 SWANK> ")
1925
1926 ("(+ 1\n" "2)" "SWANK> (+ 1
1927 2)
1928 3
1929 SWANK> "))
1930 (with-canonicalized-slime-repl-buffer
1931 (insert before)
1932 (save-excursion (insert after))
1933 (slime-test-expect "Buffer contains input"
1934 (concat "SWANK> " before after)
1935 (buffer-string))
1936 (call-interactively 'slime-repl-return)
1937 (slime-sync-to-top-level 5)
1938 (slime-test-expect "Buffer contains result"
1939 result-contents (buffer-string))))
1940
1941 (def-slime-test repl-read
1942 (prompt input result-contents)
1943 "Test simple commands in the minibuffer."
1944 '(("(read-line)" "foo" "SWANK> (values (read-line))
1945 foo
1946 \"foo\"
1947 SWANK> ")
1948 ("(read-char)" "1" "SWANK> (values (read-char))
1949 1
1950 #\\1
1951 SWANK> ")
1952 ("(read)" "(+ 2 3
1953 4)" "SWANK> (values (read))
1954 \(+ 2 3
1955 4)
1956 \(+ 2 3 4)
1957 SWANK> "))
1958 (with-canonicalized-slime-repl-buffer
1959 (insert (format "(values %s)" prompt))
1960 (call-interactively 'slime-repl-return)
1961 (slime-wait-condition "reading" #'slime-reading-p 5)
1962 (insert input)
1963 (call-interactively 'slime-repl-return)
1964 (slime-sync-to-top-level 5)
1965 (slime-test-expect "Buffer contains result"
1966 result-contents (buffer-string))))
1967
1968 (def-slime-test repl-read-lines
1969 (command inputs final-contents)
1970 "Test reading multiple lines from the repl."
1971 '(("(list (read-line) (read-line) (read-line))"
1972 ("a" "b" "c")
1973 "SWANK> (list (read-line) (read-line) (read-line))
1974 a
1975 b
1976 c
1977 \(\"a\" \"b\" \"c\")
1978 SWANK> "))
1979 (with-canonicalized-slime-repl-buffer
1980 (insert command)
1981 (call-interactively 'slime-repl-return)
1982 (dolist (input inputs)
1983 (slime-wait-condition "reading" #'slime-reading-p 5)
1984 (insert input)
1985 (call-interactively 'slime-repl-return))
1986 (slime-sync-to-top-level 5)
1987 (slime-test-expect "Buffer contains result"
1988 final-contents
1989 (buffer-string)
1990 #'equal)))
1991
1992 (def-slime-test repl-type-ahead
1993 (command input final-contents)
1994 "Ensure that user input is preserved correctly.
1995 In particular, input inserted while waiting for a result."
1996 '(("(sleep 0.1)" "foo*" "SWANK> (sleep 0.1)
1997 {}NIL
1998 SWANK> [foo*]")
1999 ("(sleep 0.1)" "*foo" "SWANK> (sleep 0.1)
2000 {}NIL
2001 SWANK> [*foo]")
2002 ("(progn (sleep 0.1) (abort))" "*foo" "SWANK> (progn (sleep 0.1) (abort))
2003 {}; Evaluation aborted.
2004 SWANK> [*foo]"))
2005 (with-canonicalized-slime-repl-buffer
2006 (insert command)
2007 (call-interactively 'slime-repl-return)
2008 (save-excursion (insert (delete* ?* input)))
2009 (forward-char (position ?* input))
2010 (slime-sync-to-top-level 5)
2011 (slime-check-buffer-contents "Buffer contains result" final-contents)))
2012
2013
2014 (def-slime-test interrupt-in-blocking-read
2015 ()
2016 "Let's see what happens if we interrupt a blocking read operation."
2017 '(())
2018 (slime-check-top-level)
2019 (with-canonicalized-slime-repl-buffer
2020 (insert "(read-char)")
2021 (call-interactively 'slime-repl-return)
2022 (slime-wait-condition "reading" #'slime-reading-p 5)
2023 (slime-interrupt)
2024 (slime-wait-condition "Debugger visible"
2025 (lambda ()
2026 (and (slime-sldb-level= 1)
2027 (get-buffer-window
2028 (sldb-get-default-buffer))))
2029 5)
2030 (with-current-buffer (sldb-get-default-buffer)
2031 (sldb-continue))
2032 (slime-wait-condition "reading" #'slime-reading-p 5)
2033 (with-current-buffer (slime-output-buffer)
2034 (insert "X")
2035 (call-interactively 'slime-repl-return)
2036 (slime-sync-to-top-level 5)
2037 (slime-test-expect "Buffer contains result"
2038 "SWANK> (read-char)
2039 X
2040 #\\X
2041 SWANK> " (buffer-string)))))
2042
2043 (provide 'slime-repl)

  ViewVC Help
Powered by ViewVC 1.1.5