/[slime]/slime/swank.lisp
ViewVC logotype

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.762 - (hide annotations)
Sun Nov 27 17:57:41 2011 UTC (2 years, 4 months ago) by heller
Branch: MAIN
Changes since 1.761: +4 -3 lines
* swank.lisp (eval-in-frame-aux): Don't bind *package* during
eval.
1 heller 1.418 ;;; -*- outline-regexp:";;;;;*" indent-tabs-mode:nil coding:latin-1-unix -*-
2 dbarlow 1.27 ;;;
3 lgorrie 1.194 ;;; This code has been placed in the Public Domain. All warranties
4     ;;; are disclaimed.
5 dbarlow 1.27 ;;;
6 lgorrie 1.194 ;;;; swank.lisp
7 dbarlow 1.27 ;;;
8 lgorrie 1.194 ;;; This file defines the "Swank" TCP server for Emacs to talk to. The
9     ;;; code in this file is purely portable Common Lisp. We do require a
10     ;;; smattering of non-portable functions in order to write the server,
11     ;;; so we have defined them in `swank-backend.lisp' and implemented
12     ;;; them separately for each Lisp implementation. These extensions are
13     ;;; available to us here via the `SWANK-BACKEND' package.
14 heller 1.26
15 heller 1.58 (defpackage :swank
16 tnorderhaug 1.684 (:use :cl :swank-backend :swank-match :swank-rpc)
17 lgorrie 1.152 (:export #:startup-multiprocessing
18 heller 1.138 #:start-server
19 heller 1.178 #:create-server
20 heller 1.521 #:stop-server
21     #:restart-server
22 heller 1.138 #:ed-in-emacs
23 nsiivola 1.426 #:inspect-in-emacs
24 lgorrie 1.157 #:print-indentation-lossage
25 heller 1.561 #:invoke-slime-debugger
26 lgorrie 1.177 #:swank-debugger-hook
27 heller 1.528 #:emacs-inspect
28     ;;#:inspect-slot-for-emacs
29 lgorrie 1.194 ;; These are user-configurable variables:
30 lgorrie 1.152 #:*communication-style*
31 mbaringer 1.413 #:*dont-close*
32 heller 1.639 #:*fasl-pathname-function*
33 lgorrie 1.152 #:*log-events*
34 lgorrie 1.283 #:*log-output*
35 lgorrie 1.152 #:*use-dedicated-output-stream*
36 mbaringer 1.313 #:*dedicated-output-stream-port*
37 lgorrie 1.157 #:*configure-emacs-indentation*
38 heller 1.189 #:*readtable-alist*
39 lgorrie 1.197 #:*globally-redirect-io*
40 lgorrie 1.223 #:*global-debugger*
41 trittweiler 1.676 #:*sldb-quit-restart*
42 nsiivola 1.599 #:*backtrace-printer-bindings*
43     #:*default-worker-thread-bindings*
44     #:*macroexpand-printer-bindings*
45 heller 1.282 #:*swank-pprint-bindings*
46 lgorrie 1.300 #:*record-repl-results*
47 nsiivola 1.600 #:*inspector-verbose*
48 trittweiler 1.674 ;; This is SETFable.
49     #:debug-on-swank-error
50 lgorrie 1.194 ;; These are re-exported directly from the backend:
51 lgorrie 1.209 #:buffer-first-change
52 heller 1.649 #:frame-source-location
53 trittweiler 1.704 #:gdb-initial-commands
54 wjenkner 1.146 #:restart-frame
55 trittweiler 1.548 #:sldb-step
56 heller 1.240 #:sldb-break
57     #:sldb-break-on-return
58 heller 1.142 #:profiled-functions
59     #:profile-report
60     #:profile-reset
61     #:unprofile-all
62     #:profile-package
63 heller 1.189 #:default-directory
64 heller 1.150 #:set-default-directory
65 sboukarev 1.723 #:quit-lisp
66 sboukarev 1.736 #:eval-for-emacs
67 sboukarev 1.752 #:eval-in-emacs
68     #:y-or-n-p-in-emacs))
69 dbarlow 1.27
70 heller 1.265 (in-package :swank)
71 heller 1.189
72 heller 1.343
73 lgorrie 1.194 ;;;; Top-level variables, constants, macros
74    
75     (defconstant cl-package (find-package :cl)
76     "The COMMON-LISP package.")
77    
78     (defconstant keyword-package (find-package :keyword)
79     "The KEYWORD package.")
80 heller 1.31
81 heller 1.278 (defvar *canonical-package-nicknames*
82 heller 1.348 `((:common-lisp-user . :cl-user))
83 pseibel 1.211 "Canonical package names to use instead of shortest name/nickname.")
84    
85     (defvar *auto-abbreviate-dotted-packages* t
86 heller 1.348 "Abbreviate dotted package names to their last component if T.")
87 pseibel 1.211
88 lgorrie 1.194 (defconstant default-server-port 4005
89     "The default TCP port for the server (when started manually).")
90 dbarlow 1.28
91     (defvar *swank-debug-p* t
92     "When true, print extra debugging information.")
93    
94 heller 1.574 (defvar *backtrace-pprint-dispatch-table*
95     (let ((table (copy-pprint-dispatch nil)))
96 heller 1.642 (flet ((print-string (stream string)
97 heller 1.594 (cond (*print-escape*
98 heller 1.642 (escape-string string stream
99     :map '((#\" . "\\\"")
100     (#\\ . "\\\\")
101     (#\newline . "\\n")
102     (#\return . "\\r"))))
103 heller 1.602 (t (write-string string stream)))))
104 heller 1.642 (set-pprint-dispatch 'string #'print-string 0 table)
105 heller 1.574 table)))
106    
107 heller 1.520 (defvar *backtrace-printer-bindings*
108 heller 1.574 `((*print-pretty* . t)
109     (*print-readably* . nil)
110 heller 1.520 (*print-level* . 4)
111 heller 1.574 (*print-length* . 6)
112     (*print-lines* . 1)
113     (*print-right-margin* . 200)
114     (*print-pprint-dispatch* . ,*backtrace-pprint-dispatch-table*))
115 heller 1.520 "Pretter settings for printing backtraces.")
116    
117 heller 1.282 (defvar *default-worker-thread-bindings* '()
118     "An alist to initialize dynamic variables in worker threads.
119     The list has the form ((VAR . VALUE) ...). Each variable VAR will be
120     bound to the corresponding VALUE.")
121    
122     (defun call-with-bindings (alist fun)
123     "Call FUN with variables bound according to ALIST.
124     ALIST is a list of the form ((VAR . VAL) ...)."
125 heller 1.735 (if (null alist)
126     (funcall fun)
127     (let* ((rlist (reverse alist))
128     (vars (mapcar #'car rlist))
129     (vals (mapcar #'cdr rlist)))
130     (progv vars vals
131     (funcall fun)))))
132 heller 1.282
133 heller 1.288 (defmacro with-bindings (alist &body body)
134     "See `call-with-bindings'."
135     `(call-with-bindings ,alist (lambda () ,@body)))
136    
137 lgorrie 1.194 ;;; The `DEFSLIMEFUN' macro defines a function that Emacs can call via
138     ;;; RPC.
139 heller 1.47
140 lgorrie 1.157 (defmacro defslimefun (name arglist &body rest)
141 lgorrie 1.194 "A DEFUN for functions that Emacs can call by RPC."
142 heller 1.47 `(progn
143 heller 1.250 (defun ,name ,arglist ,@rest)
144     ;; see <http://www.franz.com/support/documentation/6.2/doc/pages/variables/compiler/s_cltl1-compile-file-toplevel-compatibility-p_s.htm>
145     (eval-when (:compile-toplevel :load-toplevel :execute)
146 heller 1.568 (export ',name (symbol-package ',name)))))
147 heller 1.47
148 heller 1.113 (defun missing-arg ()
149 lgorrie 1.194 "A function that the compiler knows will never to return a value.
150     You can use (MISSING-ARG) as the initform for defstruct slots that
151     must always be supplied. This way the :TYPE slot option need not
152     include some arbitrary initial value like NIL."
153 heller 1.113 (error "A required &KEY or &OPTIONAL argument was not supplied."))
154    
155 heller 1.343
156 lgorrie 1.197 ;;;; Hooks
157     ;;;
158     ;;; We use Emacs-like `add-hook' and `run-hook' utilities to support
159     ;;; simple indirection. The interface is more CLish than the Emacs
160     ;;; Lisp one.
161    
162     (defmacro add-hook (place function)
163 heller 1.222 "Add FUNCTION to the list of values on PLACE."
164 lgorrie 1.197 `(pushnew ,function ,place))
165    
166     (defun run-hook (functions &rest arguments)
167     "Call each of FUNCTIONS with ARGUMENTS."
168     (dolist (function functions)
169     (apply function arguments)))
170    
171     (defvar *new-connection-hook* '()
172     "This hook is run each time a connection is established.
173     The connection structure is given as the argument.
174     Backend code should treat the connection structure as opaque.")
175    
176     (defvar *connection-closed-hook* '()
177     "This hook is run when a connection is closed.
178     The connection as passed as an argument.
179     Backend code should treat the connection structure as opaque.")
180    
181     (defvar *pre-reply-hook* '()
182     "Hook run (without arguments) immediately before replying to an RPC.")
183    
184 heller 1.405 (defvar *after-init-hook* '()
185     "Hook run after user init files are loaded.")
186    
187 heller 1.343
188 lgorrie 1.96 ;;;; Connections
189     ;;;
190     ;;; Connection structures represent the network connections between
191     ;;; Emacs and Lisp. Each has a socket stream, a set of user I/O
192     ;;; streams that redirect to Emacs, and optionally a second socket
193 heller 1.628 ;;; used solely to pipe user-output to Emacs (an optimization). This
194     ;;; is also the place where we keep everything that needs to be
195     ;;; freed/closed/killed when we disconnect.
196 lgorrie 1.90
197     (defstruct (connection
198 trittweiler 1.700 (:constructor %make-connection)
199 lgorrie 1.215 (:conc-name connection.)
200     (:print-function print-connection))
201 heller 1.707 ;; The listening socket. (usually closed)
202 trittweiler 1.700 (socket (missing-arg) :type t :read-only t)
203 heller 1.707 ;; Character I/O stream of socket connection. Read-only to avoid
204     ;; race conditions during initialization.
205     (socket-io (missing-arg) :type stream :read-only t)
206 lgorrie 1.96 ;; Optional dedicated output socket (backending `user-output' slot).
207     ;; Has a slot so that it can be closed with the connection.
208     (dedicated-output nil :type (or stream null))
209 lgorrie 1.90 ;; Streams that can be used for user interaction, with requests
210 lgorrie 1.96 ;; redirected to Emacs.
211     (user-input nil :type (or stream null))
212     (user-output nil :type (or stream null))
213 heller 1.112 (user-io nil :type (or stream null))
214 heller 1.615 ;; Bindings used for this connection (usually streams)
215     env
216 mkoeppe 1.499 ;; A stream that we use for *trace-output*; if nil, we user user-output.
217     (trace-output nil :type (or stream null))
218 mkoeppe 1.445 ;; A stream where we send REPL results.
219     (repl-results nil :type (or stream null))
220 lgorrie 1.194 ;; In multithreaded systems we delegate certain tasks to specific
221     ;; threads. The `reader-thread' is responsible for reading network
222     ;; requests from Emacs and sending them to the `control-thread'; the
223     ;; `control-thread' is responsible for dispatching requests to the
224     ;; threads that should handle them; the `repl-thread' is the one
225     ;; that evaluates REPL expressions. The control thread dispatches
226     ;; all REPL evaluations to the REPL thread and for other requests it
227     ;; spawns new threads.
228     reader-thread
229 heller 1.134 control-thread
230 lgorrie 1.173 repl-thread
231 heller 1.613 auto-flush-thread
232 lgorrie 1.194 ;; Callback functions:
233     ;; (SERVE-REQUESTS <this-connection>) serves all pending requests
234     ;; from Emacs.
235     (serve-requests (missing-arg) :type function)
236     ;; (CLEANUP <this-connection>) is called when the connection is
237     ;; closed.
238 heller 1.113 (cleanup nil :type (or null function))
239 lgorrie 1.194 ;; Cache of macro-indentation information that has been sent to Emacs.
240     ;; This is used for preparing deltas to update Emacs's knowledge.
241     ;; Maps: symbol -> indentation-specification
242 lgorrie 1.157 (indentation-cache (make-hash-table :test 'eq) :type hash-table)
243 lgorrie 1.194 ;; The list of packages represented in the cache:
244 heller 1.261 (indentation-cache-packages '())
245     ;; The communication style used.
246     (communication-style nil :type (member nil :spawn :sigio :fd-handler))
247 heller 1.264 ;; The coding system for network streams.
248 heller 1.566 coding-system
249     ;; The SIGINT handler we should restore when the connection is
250     ;; closed.
251     saved-sigint-handler)
252 lgorrie 1.215
253     (defun print-connection (conn stream depth)
254     (declare (ignore depth))
255     (print-unreadable-object (conn stream :type t :identity t)))
256 heller 1.115
257 lgorrie 1.157 (defvar *connections* '()
258     "List of all active connections, with the most recent at the front.")
259    
260 heller 1.112 (defvar *emacs-connection* nil
261 lgorrie 1.194 "The connection to Emacs currently in use.")
262 lgorrie 1.96
263 lgorrie 1.157 (defun default-connection ()
264     "Return the 'default' Emacs connection.
265 lgorrie 1.194 This connection can be used to talk with Emacs when no specific
266     connection is in use, i.e. *EMACS-CONNECTION* is NIL.
267    
268 lgorrie 1.157 The default connection is defined (quite arbitrarily) as the most
269     recently established one."
270 lgorrie 1.194 (first *connections*))
271 lgorrie 1.157
272 heller 1.707 (defun make-connection (socket stream style coding-system)
273     (multiple-value-bind (serve cleanup)
274     (ecase style
275     (:spawn
276     (values #'spawn-threads-for-connection #'cleanup-connection-threads))
277     (:sigio
278     (values #'install-sigio-handler #'deinstall-sigio-handler))
279     (:fd-handler
280     (values #'install-fd-handler #'deinstall-fd-handler))
281     ((nil)
282     (values #'simple-serve-requests nil)))
283     (let ((conn (%make-connection :socket socket
284     :socket-io stream
285     :communication-style style
286     :coding-system coding-system
287     :serve-requests serve
288     :cleanup cleanup)))
289     (run-hook *new-connection-hook* conn)
290     (push conn *connections*)
291     conn)))
292    
293     (defun connection.external-format (connection)
294     (ignore-errors
295     (stream-external-format (connection.socket-io connection))))
296    
297 heller 1.587 (defslimefun ping (tag)
298     tag)
299    
300 heller 1.556 (defun safe-backtrace ()
301     (ignore-errors
302     (call-with-debugging-environment
303     (lambda () (backtrace 0 nil)))))
304 lgorrie 1.90
305 heller 1.716 (define-condition swank-error (error)
306     ((backtrace :initarg :backtrace :reader swank-error.backtrace)
307     (condition :initarg :condition :reader swank-error.condition))
308     (:report (lambda (c s) (princ (swank-error.condition c) s)))
309     (:documentation "Condition which carries a backtrace."))
310 heller 1.708
311 heller 1.716 (defun make-swank-error (condition &optional (backtrace (safe-backtrace)))
312     (make-condition 'swank-error :condition condition :backtrace backtrace))
313 heller 1.708
314 trittweiler 1.674 (defvar *debug-on-swank-protocol-error* nil
315     "When non-nil invoke the system debugger on errors that were
316     signalled during decoding/encoding the wire protocol. Do not set this
317     to T unless you want to debug swank internals.")
318 heller 1.563
319 heller 1.716 (defmacro with-swank-error-handler ((connection) &body body)
320     "Close the connection on internal `swank-error's."
321     (let ((conn (gensym)))
322     `(let ((,conn ,connection))
323 heller 1.563 (handler-case
324 heller 1.716 (handler-bind ((swank-error
325 heller 1.563 (lambda (condition)
326 trittweiler 1.674 (when *debug-on-swank-protocol-error*
327 heller 1.563 (invoke-default-debugger condition)))))
328 heller 1.716 (progn . ,body))
329     (swank-error (condition)
330     (close-connection ,conn
331     (swank-error.condition condition)
332     (swank-error.backtrace condition)))))))
333 trittweiler 1.648
334 heller 1.563 (defmacro with-panic-handler ((connection) &body body)
335 heller 1.716 "Close the connection on unhandled `serious-condition's."
336     (let ((conn (gensym)))
337     `(let ((,conn ,connection))
338 heller 1.563 (handler-bind ((serious-condition
339     (lambda (condition)
340 heller 1.716 (close-connection ,conn condition (safe-backtrace)))))
341 heller 1.563 . ,body))))
342    
343 lgorrie 1.197 (add-hook *new-connection-hook* 'notify-backend-of-connection)
344     (defun notify-backend-of-connection (connection)
345 heller 1.261 (declare (ignore connection))
346     (emacs-connected))
347 lgorrie 1.197
348 heller 1.343
349 trittweiler 1.505 ;;;; Utilities
350    
351 heller 1.708
352     ;;;;; Logging
353    
354     (defvar *swank-io-package*
355     (let ((package (make-package :swank-io-package :use '())))
356     (import '(nil t quote) package)
357     package))
358    
359     (defvar *log-events* nil)
360     (defvar *log-output* nil) ; should be nil for image dumpers
361    
362     (defun init-log-output ()
363     (unless *log-output*
364     (setq *log-output* (real-output-stream *error-output*))))
365    
366 trittweiler 1.714 (add-hook *after-init-hook* 'init-log-output)
367    
368 heller 1.708 (defun real-input-stream (stream)
369     (typecase stream
370     (synonym-stream
371     (real-input-stream (symbol-value (synonym-stream-symbol stream))))
372     (two-way-stream
373     (real-input-stream (two-way-stream-input-stream stream)))
374     (t stream)))
375    
376     (defun real-output-stream (stream)
377     (typecase stream
378     (synonym-stream
379     (real-output-stream (symbol-value (synonym-stream-symbol stream))))
380     (two-way-stream
381     (real-output-stream (two-way-stream-output-stream stream)))
382     (t stream)))
383    
384     (defvar *event-history* (make-array 40 :initial-element nil)
385     "A ring buffer to record events for better error messages.")
386     (defvar *event-history-index* 0)
387     (defvar *enable-event-history* t)
388    
389     (defun log-event (format-string &rest args)
390     "Write a message to *terminal-io* when *log-events* is non-nil.
391     Useful for low level debugging."
392     (with-standard-io-syntax
393     (let ((*print-readably* nil)
394     (*print-pretty* nil)
395     (*package* *swank-io-package*))
396     (when *enable-event-history*
397     (setf (aref *event-history* *event-history-index*)
398     (format nil "~?" format-string args))
399     (setf *event-history-index*
400     (mod (1+ *event-history-index*) (length *event-history*))))
401     (when *log-events*
402     (write-string (escape-non-ascii (format nil "~?" format-string args))
403     *log-output*)
404     (force-output *log-output*)))))
405    
406     (defun event-history-to-list ()
407     "Return the list of events (older events first)."
408     (let ((arr *event-history*)
409     (idx *event-history-index*))
410     (concatenate 'list (subseq arr idx) (subseq arr 0 idx))))
411    
412     (defun clear-event-history ()
413     (fill *event-history* nil)
414     (setq *event-history-index* 0))
415    
416     (defun dump-event-history (stream)
417     (dolist (e (event-history-to-list))
418     (dump-event e stream)))
419    
420     (defun dump-event (event stream)
421     (cond ((stringp event)
422     (write-string (escape-non-ascii event) stream))
423     ((null event))
424     (t
425     (write-string
426     (escape-non-ascii (format nil "Unexpected event: ~A~%" event))
427     stream))))
428    
429     (defun escape-non-ascii (string)
430     "Return a string like STRING but with non-ascii chars escaped."
431     (cond ((ascii-string-p string) string)
432     (t (with-output-to-string (out)
433     (loop for c across string do
434     (cond ((ascii-char-p c) (write-char c out))
435     (t (format out "\\x~4,'0X" (char-code c)))))))))
436    
437     (defun ascii-string-p (o)
438     (and (stringp o)
439     (every #'ascii-char-p o)))
440    
441     (defun ascii-char-p (c)
442     (<= (char-code c) 127))
443    
444    
445 trittweiler 1.505 ;;;;; Helper macros
446 lgorrie 1.96
447 heller 1.708 (defmacro destructure-case (value &rest patterns)
448     "Dispatch VALUE to one of PATTERNS.
449     A cross between `case' and `destructuring-bind'.
450     The pattern syntax is:
451     ((HEAD . ARGS) . BODY)
452     The list of patterns is searched for a HEAD `eq' to the car of
453     VALUE. If one is found, the BODY is executed with ARGS bound to the
454     corresponding values in the CDR of VALUE."
455     (let ((operator (gensym "op-"))
456     (operands (gensym "rand-"))
457     (tmp (gensym "tmp-")))
458     `(let* ((,tmp ,value)
459     (,operator (car ,tmp))
460     (,operands (cdr ,tmp)))
461     (case ,operator
462     ,@(loop for (pattern . body) in patterns collect
463     (if (eq pattern t)
464     `(t ,@body)
465     (destructuring-bind (op &rest rands) pattern
466     `(,op (destructuring-bind ,rands ,operands
467     ,@body)))))
468     ,@(if (eq (caar (last patterns)) t)
469     '()
470     `((t (error "destructure-case failed: ~S" ,tmp))))))))
471    
472 heller 1.588 ;; If true execute interrupts, otherwise queue them.
473     ;; Note: `with-connection' binds *pending-slime-interrupts*.
474 heller 1.566 (defvar *slime-interrupts-enabled*)
475    
476 heller 1.588 (defmacro with-interrupts-enabled% (flag body)
477 heller 1.566 `(progn
478 heller 1.709 ,@(if flag '((check-slime-interrupts)))
479 heller 1.587 (multiple-value-prog1
480 heller 1.588 (let ((*slime-interrupts-enabled* ,flag))
481 heller 1.587 ,@body)
482 heller 1.709 ,@(if flag '((check-slime-interrupts))))))
483 heller 1.566
484 heller 1.588 (defmacro with-slime-interrupts (&body body)
485     `(with-interrupts-enabled% t ,body))
486    
487 heller 1.566 (defmacro without-slime-interrupts (&body body)
488 heller 1.588 `(with-interrupts-enabled% nil ,body))
489 heller 1.566
490     (defun invoke-or-queue-interrupt (function)
491 heller 1.619 (log-event "invoke-or-queue-interrupt: ~a~%" function)
492 heller 1.566 (cond ((not (boundp '*slime-interrupts-enabled*))
493     (without-slime-interrupts
494     (funcall function)))
495     (*slime-interrupts-enabled*
496 heller 1.619 (log-event "interrupts-enabled~%")
497 heller 1.566 (funcall function))
498     (t
499 heller 1.587 (setq *pending-slime-interrupts*
500     (nconc *pending-slime-interrupts*
501     (list function)))
502     (cond ((cdr *pending-slime-interrupts*)
503 heller 1.619 (log-event "too many queued interrupts~%")
504 heller 1.709 (with-simple-restart (continue "Continue from interrupt")
505     (handler-bind ((serious-condition #'invoke-slime-debugger))
506     (check-slime-interrupts))))
507 heller 1.587 (t
508 heller 1.709 (log-event "queue-interrupt: ~a~%" function)
509 heller 1.634 (when *interrupt-queued-handler*
510     (funcall *interrupt-queued-handler*)))))))
511 heller 1.566
512    
513 lgorrie 1.174 (defmacro with-io-redirection ((connection) &body body)
514 heller 1.615 "Execute BODY I/O redirection to CONNECTION. "
515     `(with-bindings (connection.env ,connection)
516     . ,body))
517 heller 1.293
518 heller 1.153 (defmacro with-connection ((connection) &body body)
519     "Execute BODY in the context of CONNECTION."
520 heller 1.718 `(let ((connection ,connection)
521     (function (lambda () . ,body)))
522     (if (eq *emacs-connection* connection)
523     (funcall function)
524     (let ((*emacs-connection* connection)
525     (*pending-slime-interrupts* '()))
526     (without-slime-interrupts
527     (with-swank-error-handler (connection)
528     (with-io-redirection (connection)
529     (call-with-debugger-hook #'swank-debugger-hook function))))))))
530 lgorrie 1.96
531 trittweiler 1.584 (defun call-with-retry-restart (msg thunk)
532 heller 1.605 (loop (with-simple-restart (retry "~a" msg)
533     (return (funcall thunk)))))
534 trittweiler 1.584
535     (defmacro with-retry-restart ((&key (msg "Retry.")) &body body)
536     (check-type msg string)
537 heller 1.720 `(call-with-retry-restart ,msg (lambda () ,@body)))
538 trittweiler 1.584
539 heller 1.556 (defmacro with-struct* ((conc-name get obj) &body body)
540     (let ((var (gensym)))
541     `(let ((,var ,obj))
542     (macrolet ((,get (slot)
543     (let ((getter (intern (concatenate 'string
544     ',(string conc-name)
545     (string slot))
546     (symbol-package ',conc-name))))
547     `(,getter ,',var))))
548     ,@body))))
549    
550 trittweiler 1.505 (defmacro do-symbols* ((var &optional (package '*package*) result-form) &body body)
551     "Just like do-symbols, but makes sure a symbol is visited only once."
552     (let ((seen-ht (gensym "SEEN-HT")))
553     `(let ((,seen-ht (make-hash-table :test #'eq)))
554     (do-symbols (,var ,package ,result-form)
555     (unless (gethash ,var ,seen-ht)
556     (setf (gethash ,var ,seen-ht) t)
557 trittweiler 1.629 (tagbody ,@body))))))
558 trittweiler 1.505
559 trittweiler 1.676 (defmacro define-special (name doc)
560     "Define a special variable NAME with doc string DOC.
561     This is like defvar, but NAME will not be initialized."
562     `(progn
563     (defvar ,name)
564     (setf (documentation ',name 'variable) ,doc)))
565 trittweiler 1.584
566 trittweiler 1.505
567 trittweiler 1.714 ;;;;; Misc
568 trittweiler 1.505
569 trittweiler 1.714 (defun use-threads-p ()
570     (eq (connection.communication-style *emacs-connection*) :spawn))
571    
572     (defun current-thread-id ()
573     (thread-id (current-thread)))
574    
575     (declaim (inline ensure-list))
576     (defun ensure-list (thing)
577     (if (listp thing) thing (list thing)))
578 heller 1.560
579 trittweiler 1.505
580     ;;;;; Symbols
581    
582     (defun symbol-status (symbol &optional (package (symbol-package symbol)))
583     "Returns one of
584    
585     :INTERNAL if the symbol is _present_ in PACKAGE as an _internal_ symbol,
586    
587     :EXTERNAL if the symbol is _present_ in PACKAGE as an _external_ symbol,
588    
589     :INHERITED if the symbol is _inherited_ by PACKAGE through USE-PACKAGE,
590     but is not _present_ in PACKAGE,
591    
592     or NIL if SYMBOL is not _accessible_ in PACKAGE.
593    
594    
595     Be aware not to get confused with :INTERNAL and how \"internal
596     symbols\" are defined in the spec; there is a slight mismatch of
597     definition with the Spec and what's commonly meant when talking
598     about internal symbols most times. As the spec says:
599    
600     In a package P, a symbol S is
601    
602     _accessible_ if S is either _present_ in P itself or was
603     inherited from another package Q (which implies
604     that S is _external_ in Q.)
605    
606     You can check that with: (AND (SYMBOL-STATUS S P) T)
607    
608    
609     _present_ if either P is the /home package/ of S or S has been
610     imported into P or exported from P by IMPORT, or
611     EXPORT respectively.
612    
613     Or more simply, if S is not _inherited_.
614    
615     You can check that with: (LET ((STATUS (SYMBOL-STATUS S P)))
616     (AND STATUS
617     (NOT (EQ STATUS :INHERITED))))
618    
619    
620     _external_ if S is going to be inherited into any package that
621     /uses/ P by means of USE-PACKAGE, MAKE-PACKAGE, or
622     DEFPACKAGE.
623    
624     Note that _external_ implies _present_, since to
625     make a symbol _external_, you'd have to use EXPORT
626     which will automatically make the symbol _present_.
627    
628     You can check that with: (EQ (SYMBOL-STATUS S P) :EXTERNAL)
629    
630    
631     _internal_ if S is _accessible_ but not _external_.
632    
633     You can check that with: (LET ((STATUS (SYMBOL-STATUS S P)))
634     (AND STATUS
635     (NOT (EQ STATUS :EXTERNAL))))
636    
637    
638     Notice that this is *different* to
639     (EQ (SYMBOL-STATUS S P) :INTERNAL)
640     because what the spec considers _internal_ is split up into two
641     explicit pieces: :INTERNAL, and :INHERITED; just as, for instance,
642     CL:FIND-SYMBOL does.
643    
644     The rationale is that most times when you speak about \"internal\"
645     symbols, you're actually not including the symbols inherited
646     from other packages, but only about the symbols directly specific
647     to the package in question.
648     "
649     (when package ; may be NIL when symbol is completely uninterned.
650     (check-type symbol symbol) (check-type package package)
651     (multiple-value-bind (present-symbol status)
652     (find-symbol (symbol-name symbol) package)
653     (and (eq symbol present-symbol) status))))
654    
655     (defun symbol-external-p (symbol &optional (package (symbol-package symbol)))
656     "True if SYMBOL is external in PACKAGE.
657     If PACKAGE is not specified, the home package of SYMBOL is used."
658     (eq (symbol-status symbol package) :external))
659    
660    
661     (defun classify-symbol (symbol)
662 trittweiler 1.539 "Returns a list of classifiers that classify SYMBOL according to its
663     underneath objects (e.g. :BOUNDP if SYMBOL constitutes a special
664     variable.) The list may contain the following classification
665     keywords: :BOUNDP, :FBOUNDP, :CONSTANT, :GENERIC-FUNCTION,
666     :TYPESPEC, :CLASS, :MACRO, :SPECIAL-OPERATOR, and/or :PACKAGE"
667 trittweiler 1.505 (check-type symbol symbol)
668 trittweiler 1.539 (flet ((type-specifier-p (s)
669     (or (documentation s 'type)
670     (not (eq (type-specifier-arglist s) :not-available)))))
671     (let (result)
672     (when (boundp symbol) (push (if (constantp symbol)
673     :constant :boundp) result))
674     (when (fboundp symbol) (push :fboundp result))
675     (when (type-specifier-p symbol) (push :typespec result))
676     (when (find-class symbol nil) (push :class result))
677     (when (macro-function symbol) (push :macro result))
678     (when (special-operator-p symbol) (push :special-operator result))
679     (when (find-package symbol) (push :package result))
680 sboukarev 1.673 (when (and (fboundp symbol)
681     (typep (ignore-errors (fdefinition symbol))
682     'generic-function))
683 trittweiler 1.539 (push :generic-function result))
684    
685     result)))
686 trittweiler 1.505
687 sboukarev 1.712 (defun symbol-classification-string (symbol)
688     "Return a string in the form -f-c---- where each letter stands for
689     boundp fboundp generic-function class macro special-operator package"
690     (let ((letters "bfgctmsp")
691     (result (copy-seq "--------")))
692     (flet ((type-specifier-p (s)
693     (or (documentation s 'type)
694     (not (eq (type-specifier-arglist s) :not-available))))
695     (flip (letter)
696     (setf (char result (position letter letters))
697     letter)))
698     (when (boundp symbol) (flip #\b))
699     (when (fboundp symbol)
700     (flip #\f)
701     (when (typep (ignore-errors (fdefinition symbol))
702     'generic-function)
703     (flip #\g)))
704     (when (type-specifier-p symbol) (flip #\t))
705     (when (find-class symbol nil) (flip #\c) )
706     (when (macro-function symbol) (flip #\m))
707     (when (special-operator-p symbol) (flip #\s))
708     (when (find-package symbol) (flip #\p))
709     result)))
710 mbaringer 1.411
711 heller 1.343
712 lgorrie 1.90 ;;;; TCP Server
713 dbarlow 1.28
714 heller 1.377 (defvar *use-dedicated-output-stream* nil
715 mbaringer 1.313 "When T swank will attempt to create a second connection to
716     Emacs which is used just to send output.")
717 heller 1.352
718 mbaringer 1.313 (defvar *dedicated-output-stream-port* 0
719 heller 1.330 "Which port we should use for the dedicated output stream.")
720    
721 lgorrie 1.152 (defvar *communication-style* (preferred-communication-style))
722 heller 1.79
723 mbaringer 1.413 (defvar *dont-close* nil
724     "Default value of :dont-close argument to start-server and
725     create-server.")
726    
727 heller 1.352 (defvar *dedicated-output-stream-buffering*
728     (if (eq *communication-style* :spawn) :full :none)
729     "The buffering scheme that should be used for the output stream.
730     Valid values are :none, :line, and :full.")
731    
732 heller 1.419 (defvar *coding-system* "iso-latin-1-unix")
733    
734 heller 1.521 (defvar *listener-sockets* nil
735     "A property list of lists containing style, socket pairs used
736     by swank server listeners, keyed on socket port number. They
737     are used to close sockets on server shutdown or restart.")
738    
739 heller 1.264 (defun start-server (port-file &key (style *communication-style*)
740 mbaringer 1.413 (dont-close *dont-close*)
741 heller 1.418 (coding-system *coding-system*))
742 lgorrie 1.212 "Start the server and write the listen port number to PORT-FILE.
743     This is the entry point for Emacs."
744 heller 1.681 (setup-server 0
745     (lambda (port) (announce-server-port port-file port))
746 trittweiler 1.704 style dont-close coding-system))
747 heller 1.178
748 lgorrie 1.194 (defun create-server (&key (port default-server-port)
749 heller 1.178 (style *communication-style*)
750 heller 1.418 (dont-close *dont-close*)
751     (coding-system *coding-system*))
752 lgorrie 1.212 "Start a SWANK server on PORT running in STYLE.
753     If DONT-CLOSE is true then the listen socket will accept multiple
754     connections, otherwise it will be closed after the first."
755 trittweiler 1.696 (setup-server port #'simple-announce-function
756 trittweiler 1.704 style dont-close coding-system))
757 heller 1.418
758     (defun find-external-format-or-lose (coding-system)
759     (or (find-external-format coding-system)
760     (error "Unsupported coding system: ~s" coding-system)))
761 heller 1.178
762 heller 1.119 (defparameter *loopback-interface* "127.0.0.1")
763    
764 trittweiler 1.704 (defun setup-server (port announce-fn style dont-close coding-system)
765 heller 1.111 (declare (type function announce-fn))
766 heller 1.560 (init-log-output)
767 sboukarev 1.725 (find-external-format-or-lose coding-system)
768 heller 1.707 (let* ((socket (create-socket *loopback-interface* port))
769     (local-port (local-port socket)))
770 heller 1.521 (funcall announce-fn local-port)
771 heller 1.264 (flet ((serve ()
772 heller 1.707 (accept-connections socket style coding-system dont-close)))
773 heller 1.264 (ecase style
774     (:spawn
775 heller 1.516 (initialize-multiprocessing
776     (lambda ()
777 sboukarev 1.725 (spawn (lambda ()
778 heller 1.537 (cond ((not dont-close) (serve))
779     (t (loop (ignore-errors (serve))))))
780     :name (cat "Swank " (princ-to-string port))))))
781 heller 1.264 ((:fd-handler :sigio)
782     (add-fd-handler socket (lambda () (serve))))
783 heller 1.349 ((nil) (loop do (serve) while dont-close)))
784 heller 1.521 (setf (getf *listener-sockets* port) (list style socket))
785     local-port)))
786    
787     (defun stop-server (port)
788     "Stop server running on PORT."
789     (let* ((socket-description (getf *listener-sockets* port))
790     (style (first socket-description))
791     (socket (second socket-description)))
792     (ecase style
793     (:spawn
794     (let ((thread-position
795     (position-if
796     (lambda (x)
797 heller 1.613 (string-equal (second x)
798     (cat "Swank " (princ-to-string port))))
799 heller 1.521 (list-threads))))
800     (when thread-position
801 sboukarev 1.663 (kill-nth-thread (1- thread-position))
802 heller 1.521 (close-socket socket)
803     (remf *listener-sockets* port))))
804     ((:fd-handler :sigio)
805     (remove-fd-handlers socket)
806     (close-socket socket)
807     (remf *listener-sockets* port)))))
808    
809     (defun restart-server (&key (port default-server-port)
810     (style *communication-style*)
811     (dont-close *dont-close*)
812     (coding-system *coding-system*))
813     "Stop the server listening on PORT, then start a new SWANK server
814     on PORT running in STYLE. If DONT-CLOSE is true then the listen socket
815     will accept multiple connections, otherwise it will be closed after the
816     first."
817     (stop-server port)
818     (sleep 5)
819     (create-server :port port :style style :dont-close dont-close
820     :coding-system coding-system))
821    
822 heller 1.707 (defun accept-connections (socket style coding-system dont-close)
823 sboukarev 1.759 (let ((client (unwind-protect
824     (accept-connection socket :external-format nil
825     :buffering t)
826     (unless dont-close
827     (close-socket socket)))))
828 heller 1.707 (authenticate-client client)
829     (serve-requests (make-connection socket client style coding-system))))
830    
831     (defun authenticate-client (stream)
832     (let ((secret (slime-secret)))
833     (when secret
834     (set-stream-timeout stream 20)
835     (let ((first-val (decode-message stream)))
836     (unless (and (stringp first-val) (string= first-val secret))
837     (error "Incoming connection doesn't know the password.")))
838     (set-stream-timeout stream nil))))
839 lgorrie 1.296
840     (defun slime-secret ()
841     "Finds the magic secret from the user's home directory. Returns nil
842     if the file doesn't exist; otherwise the first line of the file."
843     (with-open-file (in
844 lgorrie 1.297 (merge-pathnames (user-homedir-pathname) #p".slime-secret")
845 lgorrie 1.296 :if-does-not-exist nil)
846     (and in (read-line in nil ""))))
847    
848 heller 1.112 (defun serve-requests (connection)
849 heller 1.115 "Read and process all requests on connections."
850 heller 1.112 (funcall (connection.serve-requests connection) connection))
851    
852 heller 1.94 (defun announce-server-port (file port)
853     (with-open-file (s file
854     :direction :output
855 lgorrie 1.296 :if-exists :error
856 heller 1.94 :if-does-not-exist :create)
857     (format s "~S~%" port))
858     (simple-announce-function port))
859 lgorrie 1.90
860 heller 1.115 (defun simple-announce-function (port)
861     (when *swank-debug-p*
862 heller 1.511 (format *log-output* "~&;; Swank started at port: ~D.~%" port)
863     (force-output *log-output*)))
864 heller 1.115
865 heller 1.153 (defun open-streams (connection)
866 mkoeppe 1.445 "Return the 5 streams for IO redirection:
867     DEDICATED-OUTPUT INPUT OUTPUT IO REPL-RESULTS"
868 sboukarev 1.652 (let* ((input-fn
869 heller 1.581 (lambda ()
870     (with-connection (connection)
871     (with-simple-restart (abort-read
872     "Abort reading input from Emacs.")
873     (read-user-input-from-emacs)))))
874     (dedicated-output (if *use-dedicated-output-stream*
875 sboukarev 1.759 (open-dedicated-output-stream connection)))
876 heller 1.581 (in (make-input-stream input-fn))
877 sboukarev 1.652 (out (or dedicated-output
878     (make-output-stream (make-output-function connection))))
879 heller 1.581 (io (make-two-way-stream in out))
880     (repl-results (make-output-stream-for-target connection
881     :repl-result)))
882     (when (eq (connection.communication-style connection) :spawn)
883 heller 1.613 (setf (connection.auto-flush-thread connection)
884     (spawn (lambda () (auto-flush-loop out))
885     :name "auto-flush-thread")))
886 heller 1.581 (values dedicated-output in out io repl-results)))
887 lgorrie 1.90
888 heller 1.549 ;; FIXME: if wait-for-event aborts the event will stay in the queue forever.
889 heller 1.153 (defun make-output-function (connection)
890 heller 1.549 "Create function to send user output to Emacs."
891 heller 1.559 (let ((i 0) (tag 0) (l 0))
892 heller 1.549 (lambda (string)
893     (with-connection (connection)
894 heller 1.591 (multiple-value-setq (i tag l)
895     (send-user-output string i tag l))))))
896    
897     (defvar *maximum-pipelined-output-chunks* 50)
898     (defvar *maximum-pipelined-output-length* (* 80 20 5))
899     (defun send-user-output (string pcount tag plength)
900     ;; send output with flow control
901     (when (or (> pcount *maximum-pipelined-output-chunks*)
902     (> plength *maximum-pipelined-output-length*))
903     (setf tag (mod (1+ tag) 1000))
904     (send-to-emacs `(:ping ,(current-thread-id) ,tag))
905     (with-simple-restart (abort "Abort sending output to Emacs.")
906     (wait-for-event `(:emacs-pong ,tag)))
907     (setf pcount 0)
908     (setf plength 0))
909     (send-to-emacs `(:write-string ,string))
910     (values (1+ pcount) tag (+ plength (length string))))
911 heller 1.97
912 mkoeppe 1.445 (defun make-output-function-for-target (connection target)
913     "Create a function to send user output to a specific TARGET in Emacs."
914     (lambda (string)
915     (with-connection (connection)
916     (with-simple-restart
917     (abort "Abort sending output to Emacs.")
918 mkoeppe 1.502 (send-to-emacs `(:write-string ,string ,target))))))
919 mkoeppe 1.445
920 mkoeppe 1.499 (defun make-output-stream-for-target (connection target)
921     "Create a stream that sends output to a specific TARGET in Emacs."
922 heller 1.581 (make-output-stream (make-output-function-for-target connection target)))
923 mkoeppe 1.499
924 sboukarev 1.759 (defun open-dedicated-output-stream (connection)
925 lgorrie 1.90 "Open a dedicated output connection to the Emacs on SOCKET-IO.
926     Return an output stream suitable for writing program output.
927    
928     This is an optimized way for Lisp to deliver output to Emacs."
929 dcrosher 1.368 (let ((socket (create-socket *loopback-interface*
930     *dedicated-output-stream-port*)))
931     (unwind-protect
932     (let ((port (local-port socket)))
933 sboukarev 1.759 (encode-message `(:open-dedicated-output-stream
934     ,port
935     ,(connection.coding-system connection))
936     (connection.socket-io connection))
937 heller 1.707 (let ((dedicated (accept-connection
938 heller 1.418 socket
939     :external-format
940 sboukarev 1.759 (or (find-external-format
941     (connection.coding-system connection))
942 heller 1.418 :default)
943 dcrosher 1.368 :buffering *dedicated-output-stream-buffering*
944     :timeout 30)))
945 heller 1.707 (authenticate-client dedicated)
946 dcrosher 1.368 (close-socket socket)
947     (setf socket nil)
948     dedicated))
949     (when socket
950     (close-socket socket)))))
951 lgorrie 1.90
952 heller 1.708
953     ;;;;; Event Decoding/Encoding
954    
955     (defun decode-message (stream)
956     "Read an S-expression from STREAM using the SLIME protocol."
957     (log-event "decode-message~%")
958     (without-slime-interrupts
959 heller 1.716 (handler-bind ((error (lambda (c) (error (make-swank-error c)))))
960 heller 1.708 (handler-case (read-message stream *swank-io-package*)
961     (swank-reader-error (c)
962     `(:reader-error ,(swank-reader-error.packet c)
963     ,(swank-reader-error.cause c)))))))
964    
965     (defun encode-message (message stream)
966     "Write an S-expression to STREAM using the SLIME protocol."
967     (log-event "encode-message~%")
968     (without-slime-interrupts
969 heller 1.716 (handler-bind ((error (lambda (c) (error (make-swank-error c)))))
970 heller 1.708 (write-message message *swank-io-package* stream))))
971    
972    
973     ;;;;; Event Processing
974 heller 1.716
975 heller 1.718 (defvar *sldb-quit-restart* nil
976     "The restart that will be invoked when the user calls sldb-quit.")
977 heller 1.597
978     ;; Establish a top-level restart and execute BODY.
979     ;; Execute K if the restart is invoked.
980     (defmacro with-top-level-restart ((connection k) &body body)
981     `(with-connection (,connection)
982 trittweiler 1.704 (restart-case
983 heller 1.717 (let ((*sldb-quit-restart* (find-restart 'abort)))
984 trittweiler 1.704 ,@body)
985     (abort (&optional v)
986     :report "Return to SLIME's top level."
987     (declare (ignore v))
988     (force-user-output)
989     ,k))))
990 heller 1.456
991 heller 1.597 (defun handle-requests (connection &optional timeout)
992     "Read and process :emacs-rex requests.
993 heller 1.562 The processing is done in the extent of the toplevel restart."
994 heller 1.718 (with-connection (connection)
995     (cond (*sldb-quit-restart*
996     (process-requests timeout))
997     (t
998     (tagbody
999     start
1000     (with-top-level-restart (connection (go start))
1001     (process-requests timeout)))))))
1002 heller 1.562
1003 heller 1.597 (defun process-requests (timeout)
1004 heller 1.562 "Read and process requests from Emacs."
1005     (loop
1006 heller 1.589 (multiple-value-bind (event timeout?)
1007 heller 1.623 (wait-for-event `(or (:emacs-rex . _)
1008     (:emacs-channel-send . _))
1009     timeout)
1010 heller 1.597 (when timeout? (return))
1011 heller 1.623 (destructure-case event
1012     ((:emacs-rex &rest args) (apply #'eval-for-emacs args))
1013     ((:emacs-channel-send channel (selector &rest args))
1014     (channel-send channel selector args))))))
1015 heller 1.97
1016 heller 1.112 (defun current-socket-io ()
1017     (connection.socket-io *emacs-connection*))
1018    
1019 heller 1.556 (defun close-connection (c condition backtrace)
1020 heller 1.566 (let ((*debugger-hook* nil))
1021 heller 1.755 (log-event "close-connection: ~a ...~%" condition))
1022     (format *log-output* "~&;; swank:close-connection: ~A~%"
1023     (escape-non-ascii (safe-condition-message condition)))
1024 heller 1.113 (let ((cleanup (connection.cleanup c)))
1025     (when cleanup
1026     (funcall cleanup c)))
1027 heller 1.112 (close (connection.socket-io c))
1028     (when (connection.dedicated-output c)
1029 lgorrie 1.157 (close (connection.dedicated-output c)))
1030 lgorrie 1.197 (setf *connections* (remove c *connections*))
1031 lgorrie 1.217 (run-hook *connection-closed-hook* c)
1032 heller 1.390 (when (and condition (not (typep condition 'end-of-file)))
1033 heller 1.511 (finish-output *log-output*)
1034     (format *log-output* "~&;; Event history start:~%")
1035     (dump-event-history *log-output*)
1036     (format *log-output* ";; Event history end.~%~
1037 heller 1.390 ;; Backtrace:~%~{~A~%~}~
1038 heller 1.356 ;; Connection to Emacs lost. [~%~
1039     ;; condition: ~A~%~
1040     ;; type: ~S~%~
1041 trittweiler 1.697 ;; encoding: ~A vs. ~A~%~
1042     ;; style: ~S dedicated: ~S]~%"
1043 heller 1.756 (loop for (i f) in backtrace collect
1044     (ignore-errors (format nil "~d: ~a" i (escape-non-ascii f))))
1045 heller 1.356 (escape-non-ascii (safe-condition-message condition) )
1046     (type-of condition)
1047 trittweiler 1.697 (connection.coding-system c)
1048     (connection.external-format c)
1049 heller 1.356 (connection.communication-style c)
1050 heller 1.755 *use-dedicated-output-stream*))
1051     (finish-output *log-output*)
1052     (log-event "close-connection ~a ... done.~%" condition))
1053 heller 1.180
1054     ;;;;;; Thread based communication
1055    
1056 heller 1.204 (defvar *active-threads* '())
1057    
1058 heller 1.555 (defun read-loop (connection)
1059 heller 1.556 (let ((input-stream (connection.socket-io connection))
1060     (control-thread (connection.control-thread connection)))
1061 heller 1.716 (with-swank-error-handler (connection)
1062 heller 1.555 (loop (send control-thread (decode-message input-stream))))))
1063    
1064     (defun dispatch-loop (connection)
1065 heller 1.556 (let ((*emacs-connection* connection))
1066 heller 1.563 (with-panic-handler (connection)
1067 heller 1.587 (loop (dispatch-event (receive))))))
1068 heller 1.241
1069 heller 1.554 (defvar *auto-flush-interval* 0.2)
1070    
1071     (defun auto-flush-loop (stream)
1072     (loop
1073 nsiivola 1.747 (when (not (and (open-stream-p stream)
1074     (output-stream-p stream)))
1075     (return nil))
1076     ;; Use an IO timeout to avoid deadlocks
1077     ;; on the stream we're flushing.
1078     (call-with-io-timeout
1079     (lambda () (finish-output stream))
1080     :seconds 0.1)
1081     (sleep *auto-flush-interval*)))
1082 heller 1.554
1083 heller 1.556 (defun find-repl-thread (connection)
1084     (cond ((not (use-threads-p))
1085     (current-thread))
1086     (t
1087     (let ((thread (connection.repl-thread connection)))
1088 heller 1.619 (cond ((not thread) nil)
1089     ((thread-alive-p thread) thread)
1090 heller 1.556 (t
1091     (setf (connection.repl-thread connection)
1092     (spawn-repl-thread connection "new-repl-thread"))))))))
1093    
1094 heller 1.241 (defun find-worker-thread (id)
1095     (etypecase id
1096     ((member t)
1097     (car *active-threads*))
1098     ((member :repl-thread)
1099 heller 1.556 (find-repl-thread *emacs-connection*))
1100 heller 1.241 (fixnum
1101     (find-thread id))))
1102    
1103 heller 1.204 (defun interrupt-worker-thread (id)
1104 heller 1.241 (let ((thread (or (find-worker-thread id)
1105 heller 1.619 (find-repl-thread *emacs-connection*)
1106     ;; FIXME: to something better here
1107     (spawn (lambda ()) :name "ephemeral"))))
1108     (log-event "interrupt-worker-thread: ~a ~a~%" id thread)
1109     (assert thread)
1110 trittweiler 1.699 (cond ((use-threads-p)
1111     (interrupt-thread thread
1112     (lambda ()
1113     ;; safely interrupt THREAD
1114     (invoke-or-queue-interrupt #'simple-break))))
1115     (t (simple-break)))))
1116 heller 1.112
1117 heller 1.204 (defun thread-for-evaluation (id)
1118 heller 1.180 "Find or create a thread to evaluate the next request."
1119     (let ((c *emacs-connection*))
1120 heller 1.204 (etypecase id
1121 heller 1.180 ((member t)
1122 heller 1.556 (cond ((use-threads-p) (spawn-worker-thread c))
1123     (t (current-thread))))
1124 heller 1.180 ((member :repl-thread)
1125 heller 1.556 (find-repl-thread c))
1126 heller 1.180 (fixnum
1127 heller 1.204 (find-thread id)))))
1128 heller 1.274
1129     (defun spawn-worker-thread (connection)
1130     (spawn (lambda ()
1131 heller 1.288 (with-bindings *default-worker-thread-bindings*
1132 heller 1.597 (with-top-level-restart (connection nil)
1133     (apply #'eval-for-emacs
1134     (cdr (wait-for-event `(:emacs-rex . _)))))))
1135 heller 1.274 :name "worker"))
1136    
1137 heller 1.291 (defun spawn-repl-thread (connection name)
1138     (spawn (lambda ()
1139     (with-bindings *default-worker-thread-bindings*
1140     (repl-loop connection)))
1141     :name name))
1142    
1143 heller 1.557 (defun dispatch-event (event)
1144 lgorrie 1.212 "Handle an event triggered either by Emacs or within Lisp."
1145 heller 1.556 (log-event "dispatch-event: ~s~%" event)
1146 heller 1.112 (destructure-case event
1147 heller 1.204 ((:emacs-rex form package thread-id id)
1148     (let ((thread (thread-for-evaluation thread-id)))
1149 heller 1.635 (cond (thread
1150     (push thread *active-threads*)
1151     (send-event thread `(:emacs-rex ,form ,package ,id)))
1152     (t
1153     (encode-message
1154     (list :invalid-rpc id
1155     (format nil "Thread not found: ~s" thread-id))
1156     (current-socket-io))))))
1157 heller 1.112 ((:return thread &rest args)
1158 heller 1.204 (let ((tail (member thread *active-threads*)))
1159     (setq *active-threads* (nconc (ldiff *active-threads* tail)
1160 heller 1.557 (cdr tail))))
1161     (encode-message `(:return ,@args) (current-socket-io)))
1162 heller 1.204 ((:emacs-interrupt thread-id)
1163     (interrupt-worker-thread thread-id))
1164 trittweiler 1.700 (((:write-string
1165 heller 1.622 :debug :debug-condition :debug-activate :debug-return :channel-send
1166 heller 1.557 :presentation-start :presentation-end
1167 trittweiler 1.700 :new-package :new-features :ed :indentation-update
1168 heller 1.557 :eval :eval-no-wait :background-message :inspect :ping
1169 trittweiler 1.647 :y-or-n-p :read-from-minibuffer :read-string :read-aborted)
1170 heller 1.112 &rest _)
1171     (declare (ignore _))
1172 heller 1.557 (encode-message event (current-socket-io)))
1173     (((:emacs-pong :emacs-return :emacs-return-string) thread-id &rest args)
1174 heller 1.566 (send-event (find-thread thread-id) (cons (car event) args)))
1175 heller 1.623 ((:emacs-channel-send channel-id msg)
1176     (let ((ch (find-channel channel-id)))
1177     (send-event (channel-thread ch) `(:emacs-channel-send ,ch ,msg))))
1178 heller 1.569 ((:reader-error packet condition)
1179     (encode-message `(:reader-error ,packet
1180     ,(safe-condition-message condition))
1181     (current-socket-io)))))
1182 heller 1.556
1183     (defvar *event-queue* '())
1184 heller 1.587 (defvar *events-enqueued* 0)
1185 heller 1.556
1186     (defun send-event (thread event)
1187     (log-event "send-event: ~s ~s~%" thread event)
1188     (cond ((use-threads-p) (send thread event))
1189 heller 1.587 (t (setf *event-queue* (nconc *event-queue* (list event)))
1190     (setf *events-enqueued* (mod (1+ *events-enqueued*)
1191     most-positive-fixnum)))))
1192 heller 1.556
1193     (defun send-to-emacs (event)
1194     "Send EVENT to Emacs."
1195 heller 1.566 ;;(log-event "send-to-emacs: ~a" event)
1196 trittweiler 1.699 (cond ((use-threads-p)
1197 heller 1.556 (send (connection.control-thread *emacs-connection*) event))
1198     (t (dispatch-event event))))
1199    
1200 heller 1.589 (defun wait-for-event (pattern &optional timeout)
1201 heller 1.709 "Scan the event queue for PATTERN and return the event.
1202     If TIMEOUT is 'nil wait until a matching event is enqued.
1203     If TIMEOUT is 't only scan the queue without waiting.
1204     The second return value is t if the timeout expired before a matching
1205     event was found."
1206 heller 1.562 (log-event "wait-for-event: ~s ~s~%" pattern timeout)
1207 heller 1.587 (without-slime-interrupts
1208     (cond ((use-threads-p)
1209     (receive-if (lambda (e) (event-match-p e pattern)) timeout))
1210     (t
1211 heller 1.589 (wait-for-event/event-loop pattern timeout)))))
1212 heller 1.556
1213 heller 1.589 (defun wait-for-event/event-loop (pattern timeout)
1214 heller 1.562 (assert (or (not timeout) (eq timeout t)))
1215 heller 1.556 (loop
1216 heller 1.589 (check-slime-interrupts)
1217 heller 1.587 (let ((event (poll-for-event pattern)))
1218     (when event (return (car event))))
1219     (let ((events-enqueued *events-enqueued*)
1220     (ready (wait-for-input (list (current-socket-io)) timeout)))
1221     (cond ((and timeout (not ready))
1222     (return (values nil t)))
1223     ((or (/= events-enqueued *events-enqueued*)
1224     (eq ready :interrupt))
1225     ;; rescan event queue, interrupts may enqueue new events
1226     )
1227     (t
1228     (assert (equal ready (list (current-socket-io))))
1229     (dispatch-event (decode-message (current-socket-io))))))))
1230    
1231     (defun poll-for-event (pattern)
1232     (let ((tail (member-if (lambda (e) (event-match-p e pattern))
1233     *event-queue*)))
1234     (when tail
1235     (setq *event-queue* (nconc (ldiff *event-queue* tail)
1236     (cdr tail)))
1237     tail)))
1238 heller 1.556
1239 trittweiler 1.669 ;;; FIXME: Make this use SWANK-MATCH.
1240 heller 1.556 (defun event-match-p (event pattern)
1241     (cond ((or (keywordp pattern) (numberp pattern) (stringp pattern)
1242     (member pattern '(nil t)))
1243     (equal event pattern))
1244     ((symbolp pattern) t)
1245     ((consp pattern)
1246 heller 1.589 (case (car pattern)
1247     ((or) (some (lambda (p) (event-match-p event p)) (cdr pattern)))
1248     (t (and (consp event)
1249     (and (event-match-p (car event) (car pattern))
1250     (event-match-p (cdr event) (cdr pattern)))))))
1251     (t (error "Invalid pattern: ~S" pattern))))
1252 heller 1.112
1253 heller 1.153 (defun spawn-threads-for-connection (connection)
1254 heller 1.555 (setf (connection.control-thread connection)
1255     (spawn (lambda () (control-thread connection))
1256     :name "control-thread"))
1257     connection)
1258    
1259     (defun control-thread (connection)
1260 heller 1.556 (with-struct* (connection. @ connection)
1261     (setf (@ control-thread) (current-thread))
1262     (setf (@ reader-thread) (spawn (lambda () (read-loop connection))
1263     :name "reader-thread"))
1264     (dispatch-loop connection)))
1265 heller 1.153
1266 lgorrie 1.236 (defun cleanup-connection-threads (connection)
1267 heller 1.266 (let ((threads (list (connection.repl-thread connection)
1268     (connection.reader-thread connection)
1269 heller 1.613 (connection.control-thread connection)
1270     (connection.auto-flush-thread connection))))
1271 heller 1.266 (dolist (thread threads)
1272 heller 1.357 (when (and thread
1273     (thread-alive-p thread)
1274     (not (equal (current-thread) thread)))
1275 heller 1.266 (kill-thread thread)))))
1276 lgorrie 1.236
1277 lgorrie 1.173 (defun repl-loop (connection)
1278 heller 1.562 (handle-requests connection))
1279 heller 1.396
1280 heller 1.123 ;;;;;; Signal driven IO
1281    
1282 heller 1.112 (defun install-sigio-handler (connection)
1283 heller 1.566 (add-sigio-handler (connection.socket-io connection)
1284     (lambda () (process-io-interrupt connection)))
1285 heller 1.597 (handle-requests connection t))
1286 heller 1.566
1287 heller 1.579 (defvar *io-interupt-level* 0)
1288    
1289 heller 1.566 (defun process-io-interrupt (connection)
1290 heller 1.578 (log-event "process-io-interrupt ~d ...~%" *io-interupt-level*)
1291     (let ((*io-interupt-level* (1+ *io-interupt-level*)))
1292     (invoke-or-queue-interrupt
1293 heller 1.597 (lambda () (handle-requests connection t))))
1294 heller 1.578 (log-event "process-io-interrupt ~d ... done ~%" *io-interupt-level*))
1295 heller 1.566
1296 heller 1.123 (defun deinstall-sigio-handler (connection)
1297 heller 1.566 (log-event "deinstall-sigio-handler...~%")
1298 heller 1.579 (remove-sigio-handlers (connection.socket-io connection))
1299 heller 1.566 (log-event "deinstall-sigio-handler...done~%"))
1300 heller 1.123
1301     ;;;;;; SERVE-EVENT based IO
1302    
1303     (defun install-fd-handler (connection)
1304 heller 1.566 (add-fd-handler (connection.socket-io connection)
1305 heller 1.597 (lambda () (handle-requests connection t)))
1306 heller 1.566 (setf (connection.saved-sigint-handler connection)
1307 heller 1.567 (install-sigint-handler
1308     (lambda ()
1309     (invoke-or-queue-interrupt
1310 trittweiler 1.698 (lambda () (dispatch-interrupt-event connection))))))
1311 heller 1.597 (handle-requests connection t))
1312 heller 1.123
1313 trittweiler 1.698 (defun dispatch-interrupt-event (connection)
1314 trittweiler 1.699 ;; This boils down to INTERRUPT-WORKER-THREAD which uses
1315     ;; USE-THREADS-P which needs *EMACS-CONNECTION*.
1316 trittweiler 1.698 (with-connection (connection)
1317     (dispatch-event `(:emacs-interrupt ,(current-thread-id)))))
1318 heller 1.587
1319 heller 1.123 (defun deinstall-fd-handler (connection)
1320 heller 1.577 (log-event "deinstall-fd-handler~%")
1321 heller 1.566 (remove-fd-handlers (connection.socket-io connection))
1322     (install-sigint-handler (connection.saved-sigint-handler connection)))
1323 heller 1.123
1324     ;;;;;; Simple sequential IO
1325 heller 1.112
1326     (defun simple-serve-requests (connection)
1327 trittweiler 1.698 (unwind-protect
1328 heller 1.640 (with-connection (connection)
1329     (call-with-user-break-handler
1330 trittweiler 1.698 (lambda ()
1331     (invoke-or-queue-interrupt
1332 heller 1.717 (lambda () (dispatch-interrupt-event connection))))
1333 heller 1.640 (lambda ()
1334 heller 1.717 (with-simple-restart (close-connection "Close SLIME connection.")
1335 heller 1.640 (let* ((stdin (real-input-stream *standard-input*))
1336     (*standard-input* (make-repl-input-stream connection
1337     stdin)))
1338 heller 1.717 (tagbody toplevel
1339     (with-top-level-restart (connection (go toplevel))
1340     (simple-repl))))))))
1341 heller 1.556 (close-connection connection nil (safe-backtrace))))
1342 heller 1.112
1343 heller 1.722 ;; this is signalled when our custom stream thinks the end-of-file is reached.
1344     ;; (not when the end-of-file on the socket is reached)
1345     (define-condition end-of-repl-input (end-of-file) ())
1346    
1347 heller 1.614 (defun simple-repl ()
1348 heller 1.717 (loop
1349     (format t "~a> " (package-string-for-prompt *package*))
1350     (force-output)
1351     (let ((form (handler-case (read)
1352 heller 1.722 (end-of-repl-input () (return)))))
1353 heller 1.717 (let ((- form)
1354     (values (multiple-value-list (eval form))))
1355     (setq *** ** ** * * (car values)
1356     /// // // / / values
1357     +++ ++ ++ + + form)
1358     (cond ((null values) (format t "; No values~&"))
1359     (t (mapc (lambda (v) (format t "~s~&" v)) values)))))))
1360 heller 1.614
1361     (defun make-repl-input-stream (connection stdin)
1362     (make-input-stream
1363 heller 1.718 (lambda () (repl-input-stream-read connection stdin))))
1364    
1365     (defun repl-input-stream-read (connection stdin)
1366     (loop
1367     (let* ((socket (connection.socket-io connection))
1368     (inputs (list socket stdin))
1369     (ready (wait-for-input inputs)))
1370     (cond ((eq ready :interrupt)
1371     (check-slime-interrupts))
1372     ((member socket ready)
1373     ;; A Slime request from Emacs is pending; make sure to
1374     ;; redirect IO to the REPL buffer.
1375     (with-simple-restart (process-input "Continue reading input.")
1376     (let ((*sldb-quit-restart* (find-restart 'process-input)))
1377     (with-io-redirection (connection)
1378     (handle-requests connection t)))))
1379     ((member stdin ready)
1380     ;; User typed something into the *inferior-lisp* buffer,
1381     ;; so do not redirect.
1382     (return (read-non-blocking stdin)))
1383     (t (assert (null ready)))))))
1384 heller 1.614
1385     (defun read-non-blocking (stream)
1386     (with-output-to-string (str)
1387 heller 1.722 (handler-case
1388     (loop (let ((c (read-char-no-hang stream)))
1389     (unless c (return))
1390     (write-char c str)))
1391     (end-of-file () (error 'end-of-repl-input :stream stream)))))
1392    
1393 lgorrie 1.80
1394 lgorrie 1.62 ;;;; IO to Emacs
1395     ;;;
1396 lgorrie 1.197 ;;; This code handles redirection of the standard I/O streams
1397     ;;; (`*standard-output*', etc) into Emacs. The `connection' structure
1398     ;;; contains the appropriate streams, so all we have to do is make the
1399     ;;; right bindings.
1400    
1401     ;;;;; Global I/O redirection framework
1402     ;;;
1403     ;;; Optionally, the top-level global bindings of the standard streams
1404     ;;; can be assigned to be redirected to Emacs. When Emacs connects we
1405     ;;; redirect the streams into the connection, and they keep going into
1406     ;;; that connection even if more are established. If the connection
1407     ;;; handling the streams closes then another is chosen, or if there
1408     ;;; are no connections then we revert to the original (real) streams.
1409     ;;;
1410     ;;; It is slightly tricky to assign the global values of standard
1411     ;;; streams because they are often shadowed by dynamic bindings. We
1412     ;;; solve this problem by introducing an extra indirection via synonym
1413     ;;; streams, so that *STANDARD-INPUT* is a synonym stream to
1414     ;;; *CURRENT-STANDARD-INPUT*, etc. We never shadow the "current"
1415     ;;; variables, so they can always be assigned to affect a global
1416     ;;; change.
1417    
1418 heller 1.405 (defvar *globally-redirect-io* nil
1419 lgorrie 1.197 "When non-nil globally redirect all standard streams to Emacs.")
1420    
1421 heller 1.405 ;;;;; Global redirection setup
1422    
1423     (defvar *saved-global-streams* '()
1424     "A plist to save and restore redirected stream objects.
1425     E.g. the value for '*standard-output* holds the stream object
1426     for *standard-output* before we install our redirection.")
1427    
1428     (defun setup-stream-indirection (stream-var &optional stream)
1429 lgorrie 1.197 "Setup redirection scaffolding for a global stream variable.
1430     Supposing (for example) STREAM-VAR is *STANDARD-INPUT*, this macro:
1431    
1432 heller 1.405 1. Saves the value of *STANDARD-INPUT* in `*SAVED-GLOBAL-STREAMS*'.
1433 lgorrie 1.197
1434     2. Creates *CURRENT-STANDARD-INPUT*, initially with the same value as
1435     *STANDARD-INPUT*.
1436    
1437     3. Assigns *STANDARD-INPUT* to a synonym stream pointing to
1438     *CURRENT-STANDARD-INPUT*.
1439    
1440     This has the effect of making *CURRENT-STANDARD-INPUT* contain the
1441 lgorrie 1.200 effective global value for *STANDARD-INPUT*. This way we can assign
1442     the effective global value even when *STANDARD-INPUT* is shadowed by a
1443     dynamic binding."
1444 heller 1.405 (let ((current-stream-var (prefixed-var '#:current stream-var))
1445     (stream (or stream (symbol-value stream-var))))
1446     ;; Save the real stream value for the future.
1447     (setf (getf *saved-global-streams* stream-var) stream)
1448     ;; Define a new variable for the effective stream.
1449     ;; This can be reassigned.
1450     (proclaim `(special ,current-stream-var))
1451     (set current-stream-var stream)
1452     ;; Assign the real binding as a synonym for the current one.
1453 heller 1.630 (let ((stream (make-synonym-stream current-stream-var)))
1454     (set stream-var stream)
1455     (set-default-initial-binding stream-var `(quote ,stream)))))
1456 heller 1.405
1457     (defun prefixed-var (prefix variable-symbol)
1458     "(PREFIXED-VAR \"FOO\" '*BAR*) => SWANK::*FOO-BAR*"
1459     (let ((basename (subseq (symbol-name variable-symbol) 1)))
1460     (intern (format nil "*~A-~A" (string prefix) basename) :swank)))
1461 lgorrie 1.199
1462 heller 1.405 (defvar *standard-output-streams*
1463 lgorrie 1.197 '(*standard-output* *error-output* *trace-output*)
1464     "The symbols naming standard output streams.")
1465    
1466 heller 1.405 (defvar *standard-input-streams*
1467 lgorrie 1.197 '(*standard-input*)
1468     "The symbols naming standard input streams.")
1469    
1470 heller 1.405 (defvar *standard-io-streams*
1471 lgorrie 1.197 '(*debug-io* *query-io* *terminal-io*)
1472     "The symbols naming standard io streams.")
1473    
1474 heller 1.405 (defun init-global-stream-redirection ()
1475     (when *globally-redirect-io*
1476 heller 1.658 (cond (*saved-global-streams*
1477     (warn "Streams already redirected."))
1478     (t
1479     (mapc #'setup-stream-indirection
1480     (append *standard-output-streams*
1481     *standard-input-streams*
1482     *standard-io-streams*))))))
1483 heller 1.405
1484     (add-hook *after-init-hook* 'init-global-stream-redirection)
1485    
1486 lgorrie 1.197 (defun globally-redirect-io-to-connection (connection)
1487     "Set the standard I/O streams to redirect to CONNECTION.
1488     Assigns *CURRENT-<STREAM>* for all standard streams."
1489     (dolist (o *standard-output-streams*)
1490 dcrosher 1.363 (set (prefixed-var '#:current o)
1491 lgorrie 1.197 (connection.user-output connection)))
1492     ;; FIXME: If we redirect standard input to Emacs then we get the
1493     ;; regular Lisp top-level trying to read from our REPL.
1494     ;;
1495     ;; Perhaps the ideal would be for the real top-level to run in a
1496     ;; thread with local bindings for all the standard streams. Failing
1497     ;; that we probably would like to inhibit it from reading while
1498     ;; Emacs is connected.
1499     ;;
1500     ;; Meanwhile we just leave *standard-input* alone.
1501     #+NIL
1502     (dolist (i *standard-input-streams*)
1503 dcrosher 1.363 (set (prefixed-var '#:current i)
1504 lgorrie 1.197 (connection.user-input connection)))
1505     (dolist (io *standard-io-streams*)
1506 dcrosher 1.363 (set (prefixed-var '#:current io)
1507 lgorrie 1.197 (connection.user-io connection))))
1508    
1509     (defun revert-global-io-redirection ()
1510     "Set *CURRENT-<STREAM>* to *REAL-<STREAM>* for all standard streams."
1511     (dolist (stream-var (append *standard-output-streams*
1512     *standard-input-streams*
1513     *standard-io-streams*))
1514 dcrosher 1.363 (set (prefixed-var '#:current stream-var)
1515 heller 1.405 (getf *saved-global-streams* stream-var))))
1516 lgorrie 1.197
1517     ;;;;; Global redirection hooks
1518    
1519     (defvar *global-stdio-connection* nil
1520     "The connection to which standard I/O streams are globally redirected.
1521     NIL if streams are not globally redirected.")
1522    
1523     (defun maybe-redirect-global-io (connection)
1524 heller 1.620 "Consider globally redirecting to CONNECTION."
1525     (when (and *globally-redirect-io* (null *global-stdio-connection*)
1526     (connection.user-io connection))
1527 lgorrie 1.197 (setq *global-stdio-connection* connection)
1528     (globally-redirect-io-to-connection connection)))
1529    
1530     (defun update-redirection-after-close (closed-connection)
1531     "Update redirection after a connection closes."
1532 heller 1.511 (check-type closed-connection connection)
1533 lgorrie 1.197 (when (eq *global-stdio-connection* closed-connection)
1534     (if (and (default-connection) *globally-redirect-io*)
1535     ;; Redirect to another connection.
1536     (globally-redirect-io-to-connection (default-connection))
1537     ;; No more connections, revert to the real streams.
1538     (progn (revert-global-io-redirection)
1539     (setq *global-stdio-connection* nil)))))
1540    
1541     (add-hook *connection-closed-hook* 'update-redirection-after-close)
1542    
1543     ;;;;; Redirection during requests
1544     ;;;
1545     ;;; We always redirect the standard streams to Emacs while evaluating
1546     ;;; an RPC. This is done with simple dynamic bindings.
1547 dbarlow 1.28
1548 heller 1.615 (defslimefun create-repl (target)
1549     (assert (eq target nil))
1550     (let ((conn *emacs-connection*))
1551     (initialize-streams-for-connection conn)
1552     (with-struct* (connection. @ conn)
1553     (setf (@ env)
1554     `((*standard-output* . ,(@ user-output))
1555 heller 1.616 (*standard-input* . ,(@ user-input))
1556     (*trace-output* . ,(or (@ trace-output) (@ user-output)))
1557     (*error-output* . ,(@ user-output))
1558     (*debug-io* . ,(@ user-io))
1559     (*query-io* . ,(@ user-io))
1560     (*terminal-io* . ,(@ user-io))))
1561 heller 1.620 (maybe-redirect-global-io conn)
1562 heller 1.617 (when (use-threads-p)
1563 heller 1.615 (setf (@ repl-thread) (spawn-repl-thread conn "repl-thread")))
1564 heller 1.617 (list (package-name *package*)
1565     (package-string-for-prompt *package*)))))
1566 heller 1.615
1567     (defun initialize-streams-for-connection (connection)
1568     (multiple-value-bind (dedicated in out io repl-results)
1569     (open-streams connection)
1570     (setf (connection.dedicated-output connection) dedicated
1571     (connection.user-io connection) io
1572     (connection.user-output connection) out
1573     (connection.user-input connection) in
1574     (connection.repl-results connection) repl-results)
1575     connection))
1576 lgorrie 1.90
1577 heller 1.623
1578     ;;; Channels
1579    
1580     (defvar *channels* '())
1581     (defvar *channel-counter* 0)
1582    
1583     (defclass channel ()
1584     ((id :reader channel-id)
1585     (thread :initarg :thread :initform (current-thread) :reader channel-thread)
1586     (name :initarg :name :initform nil)))
1587    
1588     (defmethod initialize-instance ((ch channel) &rest initargs)
1589     (declare (ignore initargs))
1590     (call-next-method)
1591     (with-slots (id) ch
1592     (setf id (incf *channel-counter*))
1593     (push (cons id ch) *channels*)))
1594    
1595     (defmethod print-object ((c channel) stream)
1596     (print-unreadable-object (c stream :type t)
1597     (with-slots (id name) c
1598     (format stream "~d ~a" id name))))
1599    
1600     (defun find-channel (id)
1601     (cdr (assoc id *channels*)))
1602    
1603     (defgeneric channel-send (channel selector args))
1604    
1605     (defmacro define-channel-method (selector (channel &rest args) &body body)
1606     `(defmethod channel-send (,channel (selector (eql ',selector)) args)
1607     (destructuring-bind ,args args
1608     . ,body)))
1609    
1610     (defun send-to-remote-channel (channel-id msg)
1611     (send-to-emacs `(:channel-send ,channel-id ,msg)))
1612    
1613     (defclass listener-channel (channel)
1614     ((remote :initarg :remote)
1615     (env :initarg :env)))
1616    
1617     (defslimefun create-listener (remote)
1618     (let* ((pkg *package*)
1619     (conn *emacs-connection*)
1620     (ch (make-instance 'listener-channel
1621     :remote remote
1622     :env (initial-listener-bindings remote))))
1623    
1624     (with-slots (thread id) ch
1625     (when (use-threads-p)
1626     (setf thread (spawn-listener-thread ch conn)))
1627     (list id
1628     (thread-id thread)
1629     (package-name pkg)
1630     (package-string-for-prompt pkg)))))
1631    
1632     (defun initial-listener-bindings (remote)
1633     `((*package* . ,*package*)
1634     (*standard-output*
1635     . ,(make-listener-output-stream remote))
1636     (*standard-input*
1637     . ,(make-listener-input-stream remote))))
1638    
1639     (defun spawn-listener-thread (channel connection)
1640     (spawn (lambda ()
1641     (with-connection (connection)
1642     (loop
1643     (destructure-case (wait-for-event `(:emacs-channel-send . _))
1644     ((:emacs-channel-send c (selector &rest args))
1645     (assert (eq c channel))
1646     (channel-send channel selector args))))))
1647     :name "swank-listener-thread"))
1648    
1649     (define-channel-method :eval ((c listener-channel) string)
1650     (with-slots (remote env) c
1651     (let ((aborted t))
1652     (with-bindings env
1653     (unwind-protect
1654     (let* ((form (read-from-string string))
1655     (value (eval form)))
1656     (send-to-remote-channel remote
1657     `(:write-result
1658     ,(prin1-to-string value)))
1659     (setq aborted nil))
1660     (force-output)
1661     (setf env (loop for (sym) in env
1662     collect (cons sym (symbol-value sym))))
1663     (let ((pkg (package-name *package*))
1664     (prompt (package-string-for-prompt *package*)))
1665     (send-to-remote-channel remote
1666     (if aborted
1667     `(:evaluation-aborted ,pkg ,prompt)
1668     `(:prompt ,pkg ,prompt)))))))))
1669    
1670     (defun make-listener-output-stream (remote)
1671     (make-output-stream (lambda (string)
1672     (send-to-remote-channel remote
1673     `(:write-string ,string)))))
1674    
1675     (defun make-listener-input-stream (remote)
1676     (make-input-stream
1677     (lambda ()
1678     (force-output)
1679     (let ((tag (make-tag)))
1680     (send-to-remote-channel remote
1681     `(:read-string ,(current-thread-id) ,tag))
1682     (let ((ok nil))
1683     (unwind-protect
1684     (prog1 (caddr (wait-for-event
1685     `(:emacs-return-string ,tag value)))
1686     (setq ok t))
1687     (unless ok
1688     (send-to-remote-channel remote `(:read-aborted ,tag)))))))))
1689    
1690 sboukarev 1.665
1691 trittweiler 1.545
1692 heller 1.562 (defun input-available-p (stream)
1693 heller 1.757 (loop
1694     (etypecase (wait-for-input (list stream) t)
1695     (null (return nil))
1696     (cons (return t))
1697     ((member :interrupt)))))
1698 heller 1.562
1699 lgorrie 1.50 (defvar *slime-features* nil
1700     "The feature list that has been sent to Emacs.")
1701    
1702 lgorrie 1.104 (defun send-oob-to-emacs (object)
1703 heller 1.112 (send-to-emacs object))
1704    
1705     (defun force-user-output ()
1706 heller 1.551 (force-output (connection.user-io *emacs-connection*)))
1707 heller 1.112
1708 heller 1.592 (add-hook *pre-reply-hook* 'force-user-output)
1709    
1710 heller 1.112 (defun clear-user-input ()
1711     (clear-input (connection.user-input *emacs-connection*)))
1712 lgorrie 1.62
1713 heller 1.557 (defvar *tag-counter* 0)
1714 lgorrie 1.91
1715 heller 1.557 (defun make-tag ()
1716     (setq *tag-counter* (mod (1+ *tag-counter*) (expt 2 22))))
1717 heller 1.232
1718 heller 1.112 (defun read-user-input-from-emacs ()
1719 heller 1.557 (let ((tag (make-tag)))
1720 heller 1.117 (force-output)
1721 heller 1.557 (send-to-emacs `(:read-string ,(current-thread-id) ,tag))
1722 lgorrie 1.90 (let ((ok nil))
1723 lgorrie 1.62 (unwind-protect
1724 heller 1.557 (prog1 (caddr (wait-for-event `(:emacs-return-string ,tag value)))
1725 lgorrie 1.62 (setq ok t))
1726     (unless ok
1727 heller 1.557 (send-to-emacs `(:read-aborted ,(current-thread-id) ,tag)))))))
1728 mkoeppe 1.327
1729 heller 1.330 (defun y-or-n-p-in-emacs (format-string &rest arguments)
1730 mkoeppe 1.327 "Like y-or-n-p, but ask in the Emacs minibuffer."
1731 heller 1.557 (let ((tag (make-tag))
1732 heller 1.330 (question (apply #'format nil format-string arguments)))
1733 mkoeppe 1.327 (force-output)
1734 heller 1.557 (send-to-emacs `(:y-or-n-p ,(current-thread-id) ,tag ,question))
1735 trittweiler 1.647 (third (wait-for-event `(:emacs-return ,tag result)))))
1736    
1737     (defun read-from-minibuffer-in-emacs (prompt &optional initial-value)
1738     "Ask user a question in Emacs' minibuffer. Returns \"\" when user
1739     entered nothing, returns NIL when user pressed C-g."
1740     (check-type prompt string) (check-type initial-value (or null string))
1741     (let ((tag (make-tag)))
1742     (force-output)
1743     (send-to-emacs `(:read-from-minibuffer ,(current-thread-id) ,tag
1744     ,prompt ,initial-value))
1745     (third (wait-for-event `(:emacs-return ,tag result)))))
1746    
1747 mbaringer 1.279
1748 mbaringer 1.346 (defun process-form-for-emacs (form)
1749     "Returns a string which emacs will read as equivalent to
1750     FORM. FORM can contain lists, strings, characters, symbols and
1751     numbers.
1752    
1753     Characters are converted emacs' ?<char> notaion, strings are left
1754     as they are (except for espacing any nested \" chars, numbers are
1755 alendvai 1.447 printed in base 10 and symbols are printed as their symbol-name
1756 mbaringer 1.346 converted to lower case."
1757     (etypecase form
1758     (string (format nil "~S" form))
1759     (cons (format nil "(~A . ~A)"
1760     (process-form-for-emacs (car form))
1761     (process-form-for-emacs (cdr form))))
1762     (character (format nil "?~C" form))
1763 alendvai 1.447 (symbol (concatenate 'string (when (eq (symbol-package form)
1764     #.(find-package "KEYWORD"))
1765     ":")
1766     (string-downcase (symbol-name form))))
1767 mbaringer 1.346 (number (let ((*print-base* 10))
1768     (princ-to-string form)))))
1769    
1770 heller 1.281 (defun eval-in-emacs (form &optional nowait)
1771 sboukarev 1.737 "Eval FORM in Emacs.
1772 sboukarev 1.736 `slime-enable-evaluate-in-emacs' should be set to T on the Emacs side."
1773 mbaringer 1.346 (cond (nowait
1774     (send-to-emacs `(:eval-no-wait ,(process-form-for-emacs form))))
1775     (t
1776     (force-output)
1777 heller 1.557 (let ((tag (make-tag)))
1778     (send-to-emacs `(:eval ,(current-thread-id) ,tag
1779     ,(process-form-for-emacs form)))
1780     (let ((value (caddr (wait-for-event `(:emacs-return ,tag result)))))
1781     (destructure-case value
1782 heller 1.739 ((:ok value) value)
1783     ((:error kind . data) (error "~a: ~{~a~}" kind data))
1784 heller 1.557 ((:abort) (abort))))))))
1785 heller 1.337
1786 mbaringer 1.414 (defvar *swank-wire-protocol-version* nil
1787 heller 1.418 "The version of the swank/slime communication protocol.")
1788 mbaringer 1.414
1789 heller 1.126 (defslimefun connection-info ()
1790 heller 1.343 "Return a key-value list of the form:
1791 heller 1.418 \(&key PID STYLE LISP-IMPLEMENTATION MACHINE FEATURES PACKAGE VERSION)
1792 heller 1.343 PID: is the process-id of Lisp process (or nil, depending on the STYLE)
1793     STYLE: the communication style
1794 heller 1.351 LISP-IMPLEMENTATION: a list (&key TYPE NAME VERSION)
1795 heller 1.343 FEATURES: a list of keywords
1796 mbaringer 1.413 PACKAGE: a list (&key NAME PROMPT)
1797 heller 1.418 VERSION: the protocol version"
1798 trittweiler 1.696 (let ((c *emacs-connection*))
1799     (setq *slime-features* *features*)
1800     `(:pid ,(getpid) :style ,(connection.communication-style c)
1801     :encoding (:coding-system ,(connection.coding-system c)
1802     ;; external-formats are totally implementation-dependent,
1803     ;; so better play safe.
1804 trittweiler 1.706 :external-format ,(princ-to-string
1805 trittweiler 1.696 (connection.external-format c)))
1806     :lisp-implementation (:type ,(lisp-implementation-type)
1807     :name ,(lisp-implementation-type-name)
1808 trittweiler 1.705 :version ,(lisp-implementation-version)
1809     :program ,(lisp-implementation-program))
1810 trittweiler 1.696 :machine (:instance ,(machine-instance)
1811     :type ,(machine-type)
1812     :version ,(machine-version))
1813     :features ,(features-for-emacs)
1814     :modules ,*modules*
1815     :package (:name ,(package-name *package*)
1816     :prompt ,(package-string-for-prompt *package*))
1817     :version ,*swank-wire-protocol-version*)))
1818 lgorrie 1.62
1819 heller 1.551 (defslimefun io-speed-test (&optional (n 1000) (m 1))
1820 heller 1.339 (let* ((s *standard-output*)
1821     (*trace-output* (make-broadcast-stream s *log-output*)))
1822 heller 1.337 (time (progn
1823     (dotimes (i n)
1824     (format s "~D abcdefghijklm~%" i)
1825     (when (zerop (mod n m))
1826 heller 1.551 (finish-output s)))
1827 heller 1.337 (finish-output s)
1828 heller 1.339 (when *emacs-connection*
1829     (eval-in-emacs '(message "done.")))))
1830     (terpri *trace-output*)
1831     (finish-output *trace-output*)
1832 heller 1.337 nil))
1833    
1834 trittweiler 1.674 (defun debug-on-swank-error ()
1835     (assert (eq *debug-on-swank-protocol-error* *debug-swank-backend*))
1836     *debug-on-swank-protocol-error*)
1837    
1838     (defun (setf debug-on-swank-error) (new-value)
1839     (setf *debug-on-swank-protocol-error* new-value)
1840     (setf *debug-swank-backend* new-value))
1841    
1842     (defslimefun toggle-debug-on-swank-error ()
1843     (setf (debug-on-swank-error) (not (debug-on-swank-error))))
1844    
1845 lgorrie 1.62
1846     ;;;; Reading and printing
1847 dbarlow 1.28
1848 heller 1.207 (define-special *buffer-package*
1849     "Package corresponding to slime-buffer-package.
1850 dbarlow 1.28
1851 heller 1.149 EVAL-FOR-EMACS binds *buffer-package*. Strings originating from a slime
1852 dbarlow 1.28 buffer are best read in this package. See also FROM-STRING and TO-STRING.")
1853    
1854 heller 1.207 (define-special *buffer-readtable*
1855     "Readtable associated with the current buffer")
1856 heller 1.189
1857 heller 1.568 (defmacro with-buffer-syntax ((&optional package) &body body)
1858 heller 1.189 "Execute BODY with appropriate *package* and *readtable* bindings.
1859    
1860     This should be used for code that is conceptionally executed in an
1861     Emacs buffer."
1862 heller 1.568 `(call-with-buffer-syntax ,package (lambda () ,@body)))
1863 heller 1.293
1864 heller 1.568 (defun call-with-buffer-syntax (package fun)
1865 heller 1.760 (let ((*package* (if package
1866     (guess-buffer-package package)
1867 heller 1.568 *buffer-package*)))
1868 heller 1.293 ;; Don't shadow *readtable* unnecessarily because that prevents
1869     ;; the user from assigning to it.
1870     (if (eq *readtable* *buffer-readtable*)
1871     (call-with-syntax-hooks fun)
1872     (let ((*readtable* *buffer-readtable*))
1873     (call-with-syntax-hooks fun)))))
1874 heller 1.189
1875 trittweiler 1.664 (defmacro without-printing-errors ((&key object stream
1876     (msg "<<error printing object>>"))
1877     &body body)
1878     "Catches errors during evaluation of BODY and prints MSG instead."
1879     `(handler-case (progn ,@body)
1880     (serious-condition ()
1881     ,(cond ((and stream object)
1882     (let ((gstream (gensym "STREAM+")))
1883     `(let ((,gstream ,stream))
1884     (print-unreadable-object (,object ,gstream :type t :identity t)
1885     (write-string ,msg ,gstream)))))
1886     (stream
1887     `(write-string ,msg ,stream))
1888     (object
1889     `(with-output-to-string (s)
1890     (print-unreadable-object (,object s :type t :identity t)
1891     (write-string ,msg s))))
1892     (t msg)))))
1893    
1894 heller 1.330 (defun to-string (object)
1895     "Write OBJECT in the *BUFFER-PACKAGE*.
1896 nsiivola 1.354 The result may not be readable. Handles problems with PRINT-OBJECT methods
1897     gracefully."
1898 heller 1.330 (with-buffer-syntax ()
1899     (let ((*print-readably* nil))
1900 trittweiler 1.664 (without-printing-errors (:object object :stream nil)
1901     (prin1-to-string object)))))
1902    
1903 dbarlow 1.28 (defun from-string (string)
1904     "Read string in the *BUFFER-PACKAGE*"
1905 heller 1.189 (with-buffer-syntax ()
1906     (let ((*read-suppress* nil))
1907 trittweiler 1.666 (values (read-from-string string)))))
1908 lgorrie 1.60
1909 heller 1.568 (defun parse-string (string package)
1910     "Read STRING in PACKAGE."
1911     (with-buffer-syntax (package)
1912     (let ((*read-suppress* nil))
1913     (read-from-string string))))
1914    
1915 heller 1.245 ;; FIXME: deal with #\| etc. hard to do portably.
1916     (defun tokenize-symbol (string)
1917 mbaringer 1.467 "STRING is interpreted as the string representation of a symbol
1918     and is tokenized accordingly. The result is returned in three
1919     values: The package identifier part, the actual symbol identifier
1920     part, and a flag if the STRING represents a symbol that is
1921     internal to the package identifier part. (Notice that the flag is
1922     also true with an empty package identifier part, as the STRING is
1923     considered to represent a symbol internal to some current package.)"
1924 heller 1.245 (let ((package (let ((pos (position #\: string)))
1925     (if pos (subseq string 0 pos) nil)))
1926     (symbol (let ((pos (position #\: string :from-end t)))
1927     (if pos (subseq string (1+ pos)) string)))
1928 mbaringer 1.467 (internp (not (= (count #\: string) 1))))
1929 heller 1.245 (values symbol package internp)))
1930    
1931 mkoeppe 1.370 (defun tokenize-symbol-thoroughly (string)
1932 mbaringer 1.467 "This version of TOKENIZE-SYMBOL handles escape characters."
1933 mkoeppe 1.370 (let ((package nil)
1934     (token (make-array (length string) :element-type 'character
1935     :fill-pointer 0))
1936     (backslash nil)
1937     (vertical nil)
1938     (internp nil))
1939 trittweiler 1.648 (loop for char across string do
1940     (cond
1941 mkoeppe 1.370 (backslash
1942     (vector-push-extend char token)
1943     (setq backslash nil))
1944     ((char= char #\\) ; Quotes next character, even within |...|
1945     (setq backslash t))
1946     ((char= char #\|)
1947 trittweiler 1.648 (setq vertical (not vertical)))
1948 mkoeppe 1.370 (vertical
1949     (vector-push-extend char token))
1950     ((char= char #\:)
1951 trittweiler 1.648 (cond ((and package internp)
1952 sboukarev 1.670 (return-from tokenize-symbol-thoroughly))
1953 trittweiler 1.648 (package
1954     (setq internp t))
1955     (t
1956     (setq package token
1957     token (make-array (length string)
1958     :element-type 'character
1959     :fill-pointer 0)))))
1960 mkoeppe 1.370 (t
1961     (vector-push-extend (casify-char char) token))))
1962 sboukarev 1.670 (unless vertical
1963     (values token package (or (not package) internp)))))
1964 mkoeppe 1.370
1965 trittweiler 1.488 (defun untokenize-symbol (package-name internal-p symbol-name)
1966     "The inverse of TOKENIZE-SYMBOL.
1967    
1968     (untokenize-symbol \"quux\" nil \"foo\") ==> \"quux:foo\"
1969     (untokenize-symbol \"quux\" t \"foo\") ==> \"quux::foo\"
1970     (untokenize-symbol nil nil \"foo\") ==> \"foo\"
1971     "
1972 heller 1.507 (cond ((not package-name) symbol-name)
1973     (internal-p (cat package-name "::" symbol-name))
1974     (t (cat package-name ":" symbol-name))))
1975 trittweiler 1.488
1976 mkoeppe 1.370 (defun casify-char (char)
1977     "Convert CHAR accoring to readtable-case."
1978 heller 1.245 (ecase (readtable-case *readtable*)
1979 mkoeppe 1.370 (:preserve char)
1980     (:upcase (char-upcase char))
1981     (:downcase (char-downcase char))
1982     (:invert (if (upper-case-p char)
1983     (char-downcase char)
1984     (char-upcase char)))))
1985 heller 1.245
1986 trittweiler 1.668
1987 heller 1.740 (defun find-symbol-with-status (symbol-name status
1988     &optional (package *package*))
1989 trittweiler 1.668 (multiple-value-bind (symbol flag) (find-symbol symbol-name package)
1990     (if (and flag (eq flag status))
1991     (values symbol flag)
1992     (values nil nil))))
1993    
1994 heller 1.207 (defun parse-symbol (string &optional (package *package*))
1995 heller 1.189 "Find the symbol named STRING.
1996 heller 1.277 Return the symbol and a flag indicating whether the symbols was found."
1997 trittweiler 1.668 (multiple-value-bind (sname pname internalp)
1998     (tokenize-symbol-thoroughly string)
1999 sboukarev 1.670 (when sname
2000     (let ((package (cond ((string= pname "") keyword-package)
2001     (pname (find-package pname))
2002     (t package))))
2003     (if package
2004     (multiple-value-bind (symbol flag)
2005     (if internalp
2006     (find-symbol sname package)
2007     (find-symbol-with-status sname ':external package))
2008     (values symbol flag sname package))
2009     (values nil nil nil nil))))))
2010 heller 1.189
2011 heller 1.207 (defun parse-symbol-or-lose (string &optional (package *package*))
2012     (multiple-value-bind (symbol status) (parse-symbol string package)
2013     (if status
2014     (values symbol status)
2015 heller 1.405 (error "Unknown symbol: ~A [in ~A]" string package))))
2016 heller 1.207
2017 heller 1.189 (defun parse-package (string)
2018     "Find the package named STRING.
2019     Return the package or nil."
2020 heller 1.517 ;; STRING comes usually from a (in-package STRING) form.
2021     (ignore-errors
2022     (find-package (let ((*package* *swank-io-package*))
2023     (read-from-string string)))))
2024 heller 1.190
2025 heller 1.458 (defun unparse-name (string)
2026     "Print the name STRING according to the current printer settings."
2027     ;; this is intended for package or symbol names
2028     (subseq (prin1-to-string (make-symbol string)) 2))
2029    
2030 heller 1.459 (defun guess-package (string)
2031     "Guess which package corresponds to STRING.
2032     Return nil if no package matches."
2033 nsiivola 1.595 (when string
2034     (or (find-package string)
2035     (parse-package string)
2036     (if (find #\! string) ; for SBCL
2037     (guess-package (substitute #\- #\! string))))))
2038 dbarlow 1.28
2039 heller 1.191 (defvar *readtable-alist* (default-readtable-alist)
2040 heller 1.189 "An alist mapping package names to readtables.")
2041    
2042 heller 1.459 (defun guess-buffer-readtable (package-name)
2043     (let ((package (guess-package package-name)))
2044     (or (and package
2045     (cdr (assoc (package-name package) *readtable-alist*
2046     :test #'string=)))
2047     *readtable*)))
2048 heller 1.189
2049 lgorrie 1.62
2050 lgorrie 1.218 ;;;; Evaluation
2051    
2052 heller 1.278 (defvar *pending-continuations* '()
2053     "List of continuations for Emacs. (thread local)")
2054    
2055 lgorrie 1.218 (defun guess-buffer-package (string)
2056     "Return a package for STRING.
2057     Fall back to the the current if no such package exists."
2058 heller 1.459 (or (and string (guess-package string))
2059 lgorrie 1.218 *package*))
2060    
2061     (defun eval-for-emacs (form buffer-package id)
2062 mbaringer 1.466 "Bind *BUFFER-PACKAGE* to BUFFER-PACKAGE and evaluate FORM.
2063 lgorrie 1.218 Return the result to the continuation ID.
2064     Errors are trapped and invoke our debugger."
2065 sboukarev 1.729 (let (ok result condition)
2066 heller 1.567 (unwind-protect
2067     (let ((*buffer-package* (guess-buffer-package buffer-package))
2068     (*buffer-readtable* (guess-buffer-readtable buffer-package))
2069     (*pending-continuations* (cons id *pending-continuations*)))
2070     (check-type *buffer-package* package)
2071     (check-type *buffer-readtable* readtable)
2072 trittweiler 1.584 ;; APPLY would be cleaner than EVAL.
2073 trittweiler 1.688 ;; (setq result (apply (car form) (cdr form)))
2074 sboukarev 1.729 (handler-bind ((t (lambda (c) (setf condition c))))
2075     (setq result (with-slime-interrupts (eval form))))
2076 heller 1.567 (run-hook *pre-reply-hook*)
2077     (setq ok t))
2078     (send-to-emacs `(:return ,(current-thread)
2079     ,(if ok
2080     `(:ok ,result)
2081 sboukarev 1.729 `(:abort ,(prin1-to-string condition)))
2082 heller 1.567 ,id)))))
2083 lgorrie 1.218
2084 heller 1.337 (defvar *echo-area-prefix* "=> "
2085     "A prefix that `format-values-for-echo-area' should use.")
2086    
2087 lgorrie 1.218 (defun format-values-for-echo-area (values)
2088     (with-buffer-syntax ()
2089     (let ((*print-readably* nil))
2090 heller 1.242 (cond ((null values) "; No value")
2091 heller 1.525 ((and (integerp (car values)) (null (cdr values)))
2092 heller 1.242 (let ((i (car values)))
2093 sboukarev 1.713 (format nil "~A~D (~a bit~:p, #x~X, #o~O, #b~B)"
2094     *echo-area-prefix*
2095     i (integer-length i) i i i)))
2096 heller 1.511 (t (format nil "~a~{~S~^, ~}" *echo-area-prefix* values))))))
2097 lgorrie 1.218
2098 heller 1.692 (defmacro values-to-string (values)
2099     `(format-values-for-echo-area (multiple-value-list ,values)))
2100    
2101 lgorrie 1.218 (defslimefun interactive-eval (string)
2102 heller 1.331 (with-buffer-syntax ()
2103 trittweiler 1.584 (with-retry-restart (:msg "Retry SLIME interactive evaluation request.")
2104     (let ((values (multiple-value-list (eval (from-string string)))))
2105     (finish-output)
2106     (format-values-for-echo-area values)))))
2107 lgorrie 1.218
2108 heller 1.278 (defslimefun eval-and-grab-output (string)
2109     (with-buffer-syntax ()
2110 trittweiler 1.584 (with-retry-restart (:msg "Retry SLIME evaluation request.")
2111     (let* ((s (make-string-output-stream))