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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.521 - (hide annotations)
Sun Dec 2 08:44:33 2007 UTC (6 years, 4 months ago) by heller
Branch: MAIN
Changes since 1.520: +54 -8 lines
Make it possible to close listening sockets.
Patch by Alan Caulkins <fatman@maxint.net>.

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