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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.549 - (hide annotations)
Sun Aug 3 18:23:10 2008 UTC (5 years, 8 months ago) by heller
Branch: MAIN
Changes since 1.548: +99 -47 lines
Add some flow-control.

* swank.lisp (make-output-function): Synchronize with Emacs on
every 100th chunk of output.
(wait-for-event,wait-for-event/event-loop,event-match-p): New
functions.  Used to selectively wait for some events and to queue
the other events.
(dispatch-event, read-from-socket-io): Tag non-queueable events
with :call.
(read-from-control-thread, read-from-emacs): Process
:call events only; enqueue the others.

(*log-output*): Don't use synonym-streams here.  Dereference the
symbol until we get at the real stream.
(log-event): Escape non-ascii characters more carefully.

* swank-backend.lisp (receive-if): New function.
Update backends accordingly. (not yet for ABCL and SCL)

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