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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.545 - (hide annotations)
Sat Jul 5 11:48:11 2008 UTC (5 years, 9 months ago) by trittweiler
Branch: MAIN
Changes since 1.544: +30 -4 lines
	`M-x slime-lisp-threads' will now contain a summary of what's
	currently executed in a thread that was created by Swank.

	* swank-backend.lisp (thread-description, set-thread-description):
	New interface functions to associate strings with threads.
	* swank-sbcl.lisp (thread-description, set-thread-description):
	Implemented.

	* swank.lisp (call-with-thread-description),
	(with-thread-description): New.
	(read-from-emacs): Now temporarily sets the thread-description of
	the current thread to a summary of what's going to be executed by
	the current request.
	(defslimefun list-threads): Changed return value to also contain
	a thread's description.

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