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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.551 - (hide annotations)
Mon Aug 4 20:25:24 2008 UTC (5 years, 8 months ago) by heller
Branch: MAIN
Changes since 1.550: +8 -9 lines
* swank.lisp (eval-for-emacs): Don't flush streams here as that
may now block.
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 heller 1.551 (let ((max 100) (i 0) (tag 0) (l 0))
735 heller 1.549 (lambda (string)
736     (with-connection (connection)
737     (with-simple-restart (abort "Abort sending output to Emacs.")
738 heller 1.551 (when (or (= i max) (> l (* 80 20 5)))
739 heller 1.549 (setf tag (mod (1+ tag) 1000))
740     (send-to-emacs `(:ping ,(thread-id (current-thread)) ,tag))
741     (wait-for-event `(:emacs-pong ,tag))
742 heller 1.551 (setf i 0)
743     (setf l 0))
744 heller 1.549 (incf i)
745 heller 1.551 (incf l (length string))
746 heller 1.549 (send-to-emacs `(:write-string ,string)))))))
747 heller 1.97
748 mkoeppe 1.445 (defun make-output-function-for-target (connection target)
749     "Create a function to send user output to a specific TARGET in Emacs."
750     (lambda (string)
751     (with-connection (connection)
752     (with-simple-restart
753     (abort "Abort sending output to Emacs.")
754 mkoeppe 1.502 (send-to-emacs `(:write-string ,string ,target))))))
755 mkoeppe 1.445
756 mkoeppe 1.499 (defun make-output-stream-for-target (connection target)
757     "Create a stream that sends output to a specific TARGET in Emacs."
758     (nth-value 1 (make-fn-streams
759     (lambda ()
760     (error "Should never be called"))
761     (make-output-function-for-target connection target))))
762    
763 heller 1.418 (defun open-dedicated-output-stream (socket-io)
764 lgorrie 1.90 "Open a dedicated output connection to the Emacs on SOCKET-IO.
765     Return an output stream suitable for writing program output.
766    
767     This is an optimized way for Lisp to deliver output to Emacs."
768 dcrosher 1.368 (let ((socket (create-socket *loopback-interface*
769     *dedicated-output-stream-port*)))
770     (unwind-protect
771     (let ((port (local-port socket)))
772     (encode-message `(:open-dedicated-output-stream ,port) socket-io)
773 heller 1.418 (let ((dedicated (accept-authenticated-connection
774     socket
775     :external-format
776     (or (ignore-errors
777     (stream-external-format socket-io))
778     :default)
779 dcrosher 1.368 :buffering *dedicated-output-stream-buffering*
780     :timeout 30)))
781     (close-socket socket)
782     (setf socket nil)
783     dedicated))
784     (when socket
785     (close-socket socket)))))
786 lgorrie 1.90
787 heller 1.456 (defvar *sldb-quit-restart* 'abort
788     "What restart should swank attempt to invoke when the user sldb-quits.")
789    
790 heller 1.134 (defun handle-request (connection)
791 dcrosher 1.368 "Read and process one request. The processing is done in the extent
792 heller 1.115 of the toplevel restart."
793 heller 1.112 (assert (null *swank-state-stack*))
794 heller 1.357 (let ((*swank-state-stack* '(:handle-request)))
795 heller 1.134 (with-connection (connection)
796 heller 1.456 (with-simple-restart (abort "Return to SLIME's top level.")
797     (let ((*sldb-quit-restart* (find-restart 'abort)))
798     (read-from-emacs))))))
799 heller 1.97
800 heller 1.112 (defun current-socket-io ()
801     (connection.socket-io *emacs-connection*))
802    
803 heller 1.390 (defun close-connection (c &optional condition backtrace)
804 heller 1.511 (format *log-output* "~&;; swank:close-connection: ~A~%" condition)
805 heller 1.113 (let ((cleanup (connection.cleanup c)))
806     (when cleanup
807     (funcall cleanup c)))
808 heller 1.112 (close (connection.socket-io c))
809     (when (connection.dedicated-output c)
810 lgorrie 1.157 (close (connection.dedicated-output c)))
811 lgorrie 1.197 (setf *connections* (remove c *connections*))
812 lgorrie 1.217 (run-hook *connection-closed-hook* c)
813 heller 1.390 (when (and condition (not (typep condition 'end-of-file)))
814 heller 1.511 (finish-output *log-output*)
815     (format *log-output* "~&;; Event history start:~%")
816     (dump-event-history *log-output*)
817     (format *log-output* ";; Event history end.~%~
818 heller 1.390 ;; Backtrace:~%~{~A~%~}~
819 heller 1.356 ;; Connection to Emacs lost. [~%~
820     ;; condition: ~A~%~
821     ;; type: ~S~%~
822 heller 1.418 ;; encoding: ~A style: ~S dedicated: ~S]~%"
823 heller 1.390 backtrace
824 heller 1.356 (escape-non-ascii (safe-condition-message condition) )
825     (type-of condition)
826 heller 1.418 (ignore-errors (stream-external-format (connection.socket-io c)))
827 heller 1.356 (connection.communication-style c)
828     *use-dedicated-output-stream*)
829 heller 1.511 (finish-output *log-output*)))
830 heller 1.112
831 mbaringer 1.478 (defvar *debug-on-swank-error* nil
832     "When non-nil internal swank errors will drop to a
833     debugger (not an sldb buffer). Do not set this to T unless you
834     want to debug swank internals.")
835    
836 heller 1.112 (defmacro with-reader-error-handler ((connection) &body body)
837 mbaringer 1.478 (let ((con (gensym))
838 heller 1.511 (blck (gensym)))
839 heller 1.390 `(let ((,con ,connection))
840 heller 1.511 (block ,blck
841 mbaringer 1.478 (handler-bind ((swank-error
842     (lambda (e)
843     (if *debug-on-swank-error*
844     (invoke-debugger e)
845 heller 1.511 (return-from ,blck
846     (close-connection
847     ,con
848     (swank-error.condition e)
849     (swank-error.backtrace e)))))))
850 mbaringer 1.478 (progn ,@body))))))
851 heller 1.112
852 heller 1.343 (defslimefun simple-break ()
853 heller 1.180 (with-simple-restart (continue "Continue from interrupt.")
854 heller 1.357 (call-with-debugger-hook
855     #'swank-debugger-hook
856     (lambda ()
857     (invoke-debugger
858     (make-condition 'simple-error
859     :format-control "Interrupt from Emacs")))))
860 heller 1.343 nil)
861 heller 1.180
862     ;;;;;; Thread based communication
863    
864 heller 1.204 (defvar *active-threads* '())
865    
866 heller 1.134 (defun read-loop (control-thread input-stream connection)
867     (with-reader-error-handler (connection)
868 heller 1.112 (loop (send control-thread (decode-message input-stream)))))
869    
870 heller 1.134 (defun dispatch-loop (socket-io connection)
871 heller 1.204 (let ((*emacs-connection* connection))
872 mbaringer 1.478 (handler-bind ((error (lambda (e)
873     (if *debug-on-swank-error*
874     (invoke-debugger e)
875     (return-from dispatch-loop
876     (close-connection connection e))))))
877     (loop (dispatch-event (receive) socket-io)))))
878 heller 1.112
879 heller 1.241 (defun repl-thread (connection)
880     (let ((thread (connection.repl-thread connection)))
881 heller 1.357 (when (not thread)
882     (log-event "ERROR: repl-thread is nil"))
883     (assert thread)
884     (cond ((thread-alive-p thread)
885     thread)
886     (t
887     (setf (connection.repl-thread connection)
888     (spawn-repl-thread connection "new-repl-thread"))))))
889 heller 1.241
890     (defun find-worker-thread (id)
891     (etypecase id
892     ((member t)
893     (car *active-threads*))
894     ((member :repl-thread)
895     (repl-thread *emacs-connection*))
896     (fixnum
897     (find-thread id))))
898    
899 heller 1.204 (defun interrupt-worker-thread (id)
900 heller 1.241 (let ((thread (or (find-worker-thread id)
901     (repl-thread *emacs-connection*))))
902 heller 1.129 (interrupt-thread thread #'simple-break)))
903 heller 1.112
904 heller 1.204 (defun thread-for-evaluation (id)
905 heller 1.180 "Find or create a thread to evaluate the next request."
906     (let ((c *emacs-connection*))
907 heller 1.204 (etypecase id
908 heller 1.180 ((member t)
909 heller 1.274 (spawn-worker-thread c))
910 heller 1.180 ((member :repl-thread)
911 heller 1.241 (repl-thread c))
912 heller 1.180 (fixnum
913 heller 1.204 (find-thread id)))))
914 heller 1.274
915     (defun spawn-worker-thread (connection)
916     (spawn (lambda ()
917 heller 1.288 (with-bindings *default-worker-thread-bindings*
918     (handle-request connection)))
919 heller 1.274 :name "worker"))
920    
921 heller 1.291 (defun spawn-repl-thread (connection name)
922     (spawn (lambda ()
923     (with-bindings *default-worker-thread-bindings*
924     (repl-loop connection)))
925     :name name))
926    
927 heller 1.112 (defun dispatch-event (event socket-io)
928 lgorrie 1.212 "Handle an event triggered either by Emacs or within Lisp."
929 heller 1.112 (log-event "DISPATCHING: ~S~%" event)
930     (destructure-case event
931 heller 1.204 ((:emacs-rex form package thread-id id)
932     (let ((thread (thread-for-evaluation thread-id)))
933     (push thread *active-threads*)
934 heller 1.549 (send thread `(:call eval-for-emacs ,form ,package ,id))))
935 heller 1.112 ((:return thread &rest args)
936 heller 1.204 (let ((tail (member thread *active-threads*)))
937     (setq *active-threads* (nconc (ldiff *active-threads* tail)
938     (cdr tail))))
939 heller 1.112 (encode-message `(:return ,@args) socket-io))
940 heller 1.204 ((:emacs-interrupt thread-id)
941     (interrupt-worker-thread thread-id))
942     (((:debug :debug-condition :debug-activate :debug-return)
943     thread &rest args)
944     (encode-message `(,(car event) ,(thread-id thread) ,@args) socket-io))
945 heller 1.112 ((:read-string thread &rest args)
946 heller 1.204 (encode-message `(:read-string ,(thread-id thread) ,@args) socket-io))
947 mkoeppe 1.327 ((:y-or-n-p thread &rest args)
948     (encode-message `(:y-or-n-p ,(thread-id thread) ,@args) socket-io))
949 heller 1.112 ((:read-aborted thread &rest args)
950 heller 1.204 (encode-message `(:read-aborted ,(thread-id thread) ,@args) socket-io))
951     ((:emacs-return-string thread-id tag string)
952 heller 1.549 (send (find-thread thread-id) `(:call take-input ,tag ,string)))
953 heller 1.281 ((:eval thread &rest args)
954     (encode-message `(:eval ,(thread-id thread) ,@args) socket-io))
955     ((:emacs-return thread-id tag value)
956 heller 1.549 (send (find-thread thread-id) `(:call take-input ,tag ,value)))
957     ((:emacs-pong thread-id tag)
958     (send (find-thread thread-id) `(:emacs-pong ,tag)))
959 heller 1.339 (((:write-string :presentation-start :presentation-end
960     :new-package :new-features :ed :%apply :indentation-update
961 heller 1.549 :eval-no-wait :background-message :inspect :ping)
962 heller 1.112 &rest _)
963     (declare (ignore _))
964 heller 1.281 (encode-message event socket-io))))
965 heller 1.112
966 heller 1.153 (defun spawn-threads-for-connection (connection)
967 heller 1.357 (macrolet ((without-debugger-hook (&body body)
968     `(call-with-debugger-hook nil (lambda () ,@body))))
969     (let* ((socket-io (connection.socket-io connection))
970     (control-thread (spawn (lambda ()
971     (without-debugger-hook
972     (dispatch-loop socket-io connection)))
973     :name "control-thread")))
974     (setf (connection.control-thread connection) control-thread)
975     (let ((reader-thread (spawn (lambda ()
976     (let ((go (receive)))
977     (assert (eq go 'accept-input)))
978     (without-debugger-hook
979     (read-loop control-thread socket-io
980     connection)))
981     :name "reader-thread"))
982     (repl-thread (spawn-repl-thread connection "repl-thread")))
983     (setf (connection.repl-thread connection) repl-thread)
984     (setf (connection.reader-thread connection) reader-thread)
985     (send reader-thread 'accept-input)
986     connection))))
987 heller 1.153
988 lgorrie 1.236 (defun cleanup-connection-threads (connection)
989 heller 1.266 (let ((threads (list (connection.repl-thread connection)
990     (connection.reader-thread connection)
991     (connection.control-thread connection))))
992     (dolist (thread threads)
993 heller 1.357 (when (and thread
994     (thread-alive-p thread)
995     (not (equal (current-thread) thread)))
996 heller 1.266 (kill-thread thread)))))
997 lgorrie 1.236
998 lgorrie 1.173 (defun repl-loop (connection)
999 heller 1.390 (loop (handle-request connection)))
1000 heller 1.112
1001 heller 1.122 (defun process-available-input (stream fn)
1002 heller 1.396 (loop while (input-available-p stream)
1003 heller 1.122 do (funcall fn)))
1004    
1005 heller 1.396 (defun input-available-p (stream)
1006     ;; return true iff we can read from STREAM without waiting or if we
1007     ;; hit EOF
1008     (let ((c (read-char-no-hang stream nil :eof)))
1009     (cond ((not c) nil)
1010     ((eq c :eof) t)
1011     (t
1012     (unread-char c stream)
1013     t))))
1014    
1015 heller 1.123 ;;;;;; Signal driven IO
1016    
1017 heller 1.112 (defun install-sigio-handler (connection)
1018     (let ((client (connection.socket-io connection)))
1019 heller 1.134 (flet ((handler ()
1020     (cond ((null *swank-state-stack*)
1021     (with-reader-error-handler (connection)
1022     (process-available-input
1023     client (lambda () (handle-request connection)))))
1024     ((eq (car *swank-state-stack*) :read-next-form))
1025     (t (process-available-input client #'read-from-emacs)))))
1026 heller 1.123 (add-sigio-handler client #'handler)
1027 heller 1.122 (handler))))
1028 heller 1.112
1029 heller 1.123 (defun deinstall-sigio-handler (connection)
1030     (remove-sigio-handlers (connection.socket-io connection)))
1031    
1032     ;;;;;; SERVE-EVENT based IO
1033    
1034     (defun install-fd-handler (connection)
1035     (let ((client (connection.socket-io connection)))
1036     (flet ((handler ()
1037 heller 1.134 (cond ((null *swank-state-stack*)
1038     (with-reader-error-handler (connection)
1039 trittweiler 1.548 (process-available-input
1040 heller 1.134 client (lambda () (handle-request connection)))))
1041     ((eq (car *swank-state-stack*) :read-next-form))
1042 heller 1.357 (t
1043     (process-available-input client #'read-from-emacs)))))
1044 heller 1.396 ;;;; handle sigint
1045     ;;(install-debugger-globally
1046     ;; (lambda (c h)
1047     ;; (with-reader-error-handler (connection)
1048     ;; (block debugger
1049     ;; (with-connection (connection)
1050     ;; (swank-debugger-hook c h)
1051     ;; (return-from debugger))
1052     ;; (abort)))))
1053 heller 1.123 (add-fd-handler client #'handler)
1054     (handler))))
1055    
1056     (defun deinstall-fd-handler (connection)
1057     (remove-fd-handlers (connection.socket-io connection)))
1058    
1059     ;;;;;; Simple sequential IO
1060 heller 1.112
1061     (defun simple-serve-requests (connection)
1062 heller 1.390 (unwind-protect
1063     (with-simple-restart (close-connection "Close SLIME connection")
1064     (with-reader-error-handler (connection)
1065     (loop
1066     (handle-request connection))))
1067     (close-connection connection)))
1068 heller 1.357
1069 heller 1.112 (defun read-from-socket-io ()
1070     (let ((event (decode-message (current-socket-io))))
1071     (log-event "DISPATCHING: ~S~%" event)
1072     (destructure-case event
1073 heller 1.149 ((:emacs-rex form package thread id)
1074 heller 1.113 (declare (ignore thread))
1075 heller 1.549 `(:call eval-for-emacs ,form ,package ,id))
1076 heller 1.112 ((:emacs-interrupt thread)
1077 heller 1.113 (declare (ignore thread))
1078 heller 1.549 '(:call simple-break))
1079 heller 1.112 ((:emacs-return-string thread tag string)
1080 heller 1.113 (declare (ignore thread))
1081 heller 1.549 `(:call take-input ,tag ,string))
1082 heller 1.281 ((:emacs-return thread tag value)
1083     (declare (ignore thread))
1084 heller 1.549 `(:call take-input ,tag ,value))
1085     ((:emacs-pong thread tag)
1086     (declare (ignore thread))
1087     `(:emacs-pong ,tag)))))
1088 heller 1.112
1089     (defun send-to-socket-io (event)
1090     (log-event "DISPATCHING: ~S~%" event)
1091 heller 1.269 (flet ((send (o)
1092     (without-interrupts
1093     (encode-message o (current-socket-io)))))
1094 heller 1.112 (destructure-case event
1095 heller 1.281 (((:debug-activate :debug :debug-return :read-string :read-aborted
1096 mkoeppe 1.327 :y-or-n-p :eval)
1097 heller 1.115 thread &rest args)
1098 heller 1.112 (declare (ignore thread))
1099     (send `(,(car event) 0 ,@args)))
1100     ((:return thread &rest args)
1101 heller 1.225 (declare (ignore thread))
1102 heller 1.112 (send `(:return ,@args)))
1103 heller 1.339 (((:write-string :new-package :new-features :debug-condition
1104     :presentation-start :presentation-end
1105     :indentation-update :ed :%apply :eval-no-wait
1106 heller 1.549 :background-message :inspect :ping)
1107 heller 1.112 &rest _)
1108     (declare (ignore _))
1109     (send event)))))
1110    
1111 heller 1.180 (defun initialize-streams-for-connection (connection)
1112 mkoeppe 1.445 (multiple-value-bind (dedicated in out io repl-results)
1113     (open-streams connection)
1114 heller 1.180 (setf (connection.dedicated-output connection) dedicated
1115     (connection.user-io connection) io
1116     (connection.user-output connection) out
1117 mkoeppe 1.445 (connection.user-input connection) in
1118     (connection.repl-results connection) repl-results)
1119 heller 1.180 connection))
1120    
1121 heller 1.418 (defun create-connection (socket-io style)
1122 dcrosher 1.368 (let ((success nil))
1123     (unwind-protect
1124     (let ((c (ecase style
1125     (:spawn
1126     (make-connection :socket-io socket-io
1127     :read #'read-from-control-thread
1128     :send #'send-to-control-thread
1129     :serve-requests #'spawn-threads-for-connection
1130     :cleanup #'cleanup-connection-threads))
1131     (:sigio
1132     (make-connection :socket-io socket-io
1133     :read #'read-from-socket-io
1134     :send #'send-to-socket-io
1135     :serve-requests #'install-sigio-handler
1136     :cleanup #'deinstall-sigio-handler))
1137     (:fd-handler
1138     (make-connection :socket-io socket-io
1139     :read #'read-from-socket-io
1140     :send #'send-to-socket-io
1141     :serve-requests #'install-fd-handler
1142     :cleanup #'deinstall-fd-handler))
1143     ((nil)
1144     (make-connection :socket-io socket-io
1145     :read #'read-from-socket-io
1146     :send #'send-to-socket-io
1147 heller 1.549 :serve-requests #'simple-serve-requests))
1148     )))
1149 dcrosher 1.368 (setf (connection.communication-style c) style)
1150     (initialize-streams-for-connection c)
1151     (setf success t)
1152     c)
1153     (unless success
1154     (close socket-io :abort t)))))
1155 heller 1.180
1156 lgorrie 1.80
1157 lgorrie 1.62 ;;;; IO to Emacs
1158     ;;;
1159 lgorrie 1.197 ;;; This code handles redirection of the standard I/O streams
1160     ;;; (`*standard-output*', etc) into Emacs. The `connection' structure
1161     ;;; contains the appropriate streams, so all we have to do is make the
1162     ;;; right bindings.
1163    
1164     ;;;;; Global I/O redirection framework
1165     ;;;
1166     ;;; Optionally, the top-level global bindings of the standard streams
1167     ;;; can be assigned to be redirected to Emacs. When Emacs connects we
1168     ;;; redirect the streams into the connection, and they keep going into
1169     ;;; that connection even if more are established. If the connection
1170     ;;; handling the streams closes then another is chosen, or if there
1171     ;;; are no connections then we revert to the original (real) streams.
1172     ;;;
1173     ;;; It is slightly tricky to assign the global values of standard
1174     ;;; streams because they are often shadowed by dynamic bindings. We
1175     ;;; solve this problem by introducing an extra indirection via synonym
1176     ;;; streams, so that *STANDARD-INPUT* is a synonym stream to
1177     ;;; *CURRENT-STANDARD-INPUT*, etc. We never shadow the "current"
1178     ;;; variables, so they can always be assigned to affect a global
1179     ;;; change.
1180    
1181 heller 1.405 (defvar *globally-redirect-io* nil
1182 lgorrie 1.197 "When non-nil globally redirect all standard streams to Emacs.")
1183    
1184 heller 1.405 ;;;;; Global redirection setup
1185    
1186     (defvar *saved-global-streams* '()
1187     "A plist to save and restore redirected stream objects.
1188     E.g. the value for '*standard-output* holds the stream object
1189     for *standard-output* before we install our redirection.")
1190    
1191     (defun setup-stream-indirection (stream-var &optional stream)
1192 lgorrie 1.197 "Setup redirection scaffolding for a global stream variable.
1193     Supposing (for example) STREAM-VAR is *STANDARD-INPUT*, this macro:
1194    
1195 heller 1.405 1. Saves the value of *STANDARD-INPUT* in `*SAVED-GLOBAL-STREAMS*'.
1196 lgorrie 1.197
1197     2. Creates *CURRENT-STANDARD-INPUT*, initially with the same value as
1198     *STANDARD-INPUT*.
1199    
1200     3. Assigns *STANDARD-INPUT* to a synonym stream pointing to
1201     *CURRENT-STANDARD-INPUT*.
1202    
1203     This has the effect of making *CURRENT-STANDARD-INPUT* contain the
1204 lgorrie 1.200 effective global value for *STANDARD-INPUT*. This way we can assign
1205     the effective global value even when *STANDARD-INPUT* is shadowed by a
1206     dynamic binding."
1207 heller 1.405 (let ((current-stream-var (prefixed-var '#:current stream-var))
1208     (stream (or stream (symbol-value stream-var))))
1209     ;; Save the real stream value for the future.
1210     (setf (getf *saved-global-streams* stream-var) stream)
1211     ;; Define a new variable for the effective stream.
1212     ;; This can be reassigned.
1213     (proclaim `(special ,current-stream-var))
1214     (set current-stream-var stream)
1215     ;; Assign the real binding as a synonym for the current one.
1216     (set stream-var (make-synonym-stream current-stream-var))))
1217    
1218     (defun prefixed-var (prefix variable-symbol)
1219     "(PREFIXED-VAR \"FOO\" '*BAR*) => SWANK::*FOO-BAR*"
1220     (let ((basename (subseq (symbol-name variable-symbol) 1)))
1221     (intern (format nil "*~A-~A" (string prefix) basename) :swank)))
1222 lgorrie 1.199
1223 heller 1.405 (defvar *standard-output-streams*
1224 lgorrie 1.197 '(*standard-output* *error-output* *trace-output*)
1225     "The symbols naming standard output streams.")
1226    
1227 heller 1.405 (defvar *standard-input-streams*
1228 lgorrie 1.197 '(*standard-input*)
1229     "The symbols naming standard input streams.")
1230    
1231 heller 1.405 (defvar *standard-io-streams*
1232 lgorrie 1.197 '(*debug-io* *query-io* *terminal-io*)
1233     "The symbols naming standard io streams.")
1234    
1235 heller 1.405 (defun init-global-stream-redirection ()
1236     (when *globally-redirect-io*
1237 heller 1.537 (assert (not *saved-global-streams*) () "Streams already redirected.")
1238     (mapc #'setup-stream-indirection
1239 heller 1.405 (append *standard-output-streams*
1240     *standard-input-streams*
1241     *standard-io-streams*))))
1242    
1243     (add-hook *after-init-hook* 'init-global-stream-redirection)
1244    
1245 lgorrie 1.197 (defun globally-redirect-io-to-connection (connection)
1246     "Set the standard I/O streams to redirect to CONNECTION.
1247     Assigns *CURRENT-<STREAM>* for all standard streams."
1248     (dolist (o *standard-output-streams*)
1249 dcrosher 1.363 (set (prefixed-var '#:current o)
1250 lgorrie 1.197 (connection.user-output connection)))
1251     ;; FIXME: If we redirect standard input to Emacs then we get the
1252     ;; regular Lisp top-level trying to read from our REPL.
1253     ;;
1254     ;; Perhaps the ideal would be for the real top-level to run in a
1255     ;; thread with local bindings for all the standard streams. Failing
1256     ;; that we probably would like to inhibit it from reading while
1257     ;; Emacs is connected.
1258     ;;
1259     ;; Meanwhile we just leave *standard-input* alone.
1260     #+NIL
1261     (dolist (i *standard-input-streams*)
1262 dcrosher 1.363 (set (prefixed-var '#:current i)
1263 lgorrie 1.197 (connection.user-input connection)))
1264     (dolist (io *standard-io-streams*)
1265 dcrosher 1.363 (set (prefixed-var '#:current io)
1266 lgorrie 1.197 (connection.user-io connection))))
1267    
1268     (defun revert-global-io-redirection ()
1269     "Set *CURRENT-<STREAM>* to *REAL-<STREAM>* for all standard streams."
1270     (dolist (stream-var (append *standard-output-streams*
1271     *standard-input-streams*
1272     *standard-io-streams*))
1273 dcrosher 1.363 (set (prefixed-var '#:current stream-var)
1274 heller 1.405 (getf *saved-global-streams* stream-var))))
1275 lgorrie 1.197
1276     ;;;;; Global redirection hooks
1277    
1278     (defvar *global-stdio-connection* nil
1279     "The connection to which standard I/O streams are globally redirected.
1280     NIL if streams are not globally redirected.")
1281    
1282     (defun maybe-redirect-global-io (connection)
1283     "Consider globally redirecting to a newly-established CONNECTION."
1284     (when (and *globally-redirect-io* (null *global-stdio-connection*))
1285     (setq *global-stdio-connection* connection)
1286     (globally-redirect-io-to-connection connection)))
1287    
1288     (defun update-redirection-after-close (closed-connection)
1289     "Update redirection after a connection closes."
1290 heller 1.511 (check-type closed-connection connection)
1291 lgorrie 1.197 (when (eq *global-stdio-connection* closed-connection)
1292     (if (and (default-connection) *globally-redirect-io*)
1293     ;; Redirect to another connection.
1294     (globally-redirect-io-to-connection (default-connection))
1295     ;; No more connections, revert to the real streams.
1296     (progn (revert-global-io-redirection)
1297     (setq *global-stdio-connection* nil)))))
1298    
1299     (add-hook *new-connection-hook* 'maybe-redirect-global-io)
1300     (add-hook *connection-closed-hook* 'update-redirection-after-close)
1301    
1302     ;;;;; Redirection during requests
1303     ;;;
1304     ;;; We always redirect the standard streams to Emacs while evaluating
1305     ;;; an RPC. This is done with simple dynamic bindings.
1306 dbarlow 1.28
1307 lgorrie 1.90 (defun call-with-redirected-io (connection function)
1308     "Call FUNCTION with I/O streams redirected via CONNECTION."
1309 heller 1.111 (declare (type function function))
1310 trittweiler 1.546 (let* ((io (connection.user-io connection))
1311     (in (connection.user-input connection))
1312     (out (connection.user-output connection))
1313     (trace (or (connection.trace-output connection) out))
1314     (*standard-output* out)
1315     (*error-output* out)
1316     (*trace-output* trace)
1317     (*debug-io* io)
1318     (*query-io* io)
1319     (*standard-input* in)
1320     (*terminal-io* io))
1321     (funcall function)))
1322 lgorrie 1.90
1323 trittweiler 1.545 (defun call-with-thread-description (description thunk)
1324     (let* ((thread (current-thread))
1325     (old-description (thread-description thread)))
1326     (set-thread-description thread description)
1327     (unwind-protect (funcall thunk)
1328     (set-thread-description thread old-description))))
1329    
1330     (defmacro with-thread-description (description &body body)
1331     `(call-with-thread-description ,description #'(lambda () ,@body)))
1332    
1333 heller 1.549 (defvar *event-queue* '())
1334    
1335 heller 1.112 (defun read-from-emacs ()
1336 dbarlow 1.28 "Read and process a request from Emacs."
1337 trittweiler 1.545 (flet ((request-to-string (req)
1338     (remove #\Newline
1339     (string-trim '(#\Space #\Tab)
1340     (prin1-to-string req))))
1341     (truncate-string (str n)
1342     (if (> (length str) n)
1343     (format nil "~A..." (subseq str 0 n))
1344     str)))
1345     (let ((request (funcall (connection.read *emacs-connection*))))
1346     (if (eq *communication-style* :spawn)
1347     ;; For `M-x slime-list-threads': Display what threads
1348     ;; created by swank are currently doing.
1349     (with-thread-description (truncate-string (request-to-string request) 55)
1350     (apply #'funcall request))
1351 heller 1.549 (destructure-case request
1352 heller 1.550 ((:call &rest args) (apply #'funcall args))
1353 heller 1.549 (t (setf *event-queue*
1354     (nconc *event-queue* (list request)))))))))
1355    
1356     (defun wait-for-event (pattern)
1357     (log-event "wait-for-event: %S~%" pattern)
1358     (case (connection.communication-style *emacs-connection*)
1359     (:spawn (receive-if (lambda (e) (event-match-p e pattern))))
1360     (t (wait-for-event/event-loop pattern))))
1361    
1362     (defun wait-for-event/event-loop (pattern)
1363     (loop
1364     (let ((tail (member-if (lambda (e) (event-match-p e pattern))
1365     *event-queue*)))
1366     (cond (tail
1367     (setq *event-queue*
1368     (nconc (ldiff *event-queue* tail) (cdr tail)))
1369     (return (car tail)))
1370     (t
1371     (let ((event (read-from-socket-io)))
1372     (cond ((event-match-p event pattern) (return event))
1373     ((eq (car event) :call)
1374     (apply #'funcall (cdr event)))
1375     (t
1376     (setf *event-queue*
1377     (nconc *event-queue* (list event)))))))))))
1378    
1379     (defun event-match-p (event pattern)
1380     (cond ((or (keywordp pattern) (numberp pattern) (stringp pattern)
1381     (member pattern '(nil t)))
1382     (equal event pattern))
1383     ((symbolp pattern) t)
1384     ((consp pattern)
1385     (and (consp event)
1386     (and (event-match-p (car event) (car pattern))
1387     (event-match-p (cdr event) (cdr pattern)))))
1388     (t (error "Invalid pattern: ~S" pattern))))
1389 heller 1.112
1390     (defun read-from-control-thread ()
1391 heller 1.549 (cdr (receive-if (lambda (e) (event-match-p e '(:call . _))))))
1392 heller 1.46
1393 heller 1.112 (defun decode-message (stream)
1394 heller 1.390 "Read an S-expression from STREAM using the SLIME protocol."
1395 heller 1.112 (let ((*swank-state-stack* (cons :read-next-form *swank-state-stack*)))
1396 heller 1.390 (handler-bind ((error (lambda (c) (error (make-swank-error c)))))
1397     (let* ((length (decode-message-length stream))
1398     (string (make-string length))
1399     (pos (read-sequence string stream)))
1400     (assert (= pos length) ()
1401     "Short read: length=~D pos=~D" length pos)
1402     (log-event "READ: ~S~%" string)
1403     (read-form string)))))
1404 heller 1.264
1405     (defun decode-message-length (stream)
1406     (let ((buffer (make-string 6)))
1407     (dotimes (i 6)
1408     (setf (aref buffer i) (read-char stream)))
1409     (parse-integer buffer :radix #x10)))
1410 dbarlow 1.28
1411     (defun read-form (string)
1412     (with-standard-io-syntax
1413     (let ((*package* *swank-io-package*))
1414     (read-from-string string))))
1415    
1416 lgorrie 1.50 (defvar *slime-features* nil
1417     "The feature list that has been sent to Emacs.")
1418    
1419 heller 1.112 (defun send-to-emacs (object)
1420     "Send OBJECT to Emacs."
1421     (funcall (connection.send *emacs-connection*) object))
1422 dbarlow 1.28
1423 lgorrie 1.104 (defun send-oob-to-emacs (object)
1424 heller 1.112 (send-to-emacs object))
1425    
1426     (defun send-to-control-thread (object)
1427     (send (connection.control-thread *emacs-connection*) object))
1428    
1429     (defun encode-message (message stream)
1430     (let* ((string (prin1-to-string-for-emacs message))
1431 heller 1.330 (length (length string)))
1432 heller 1.112 (log-event "WRITE: ~A~%" string)
1433 mkoeppe 1.315 (let ((*print-pretty* nil))
1434     (format stream "~6,'0x" length))
1435 heller 1.204 (write-string string stream)
1436 heller 1.330 ;;(terpri stream)
1437 heller 1.357 (finish-output stream)))
1438 lgorrie 1.104
1439 dbarlow 1.28 (defun prin1-to-string-for-emacs (object)
1440 heller 1.31 (with-standard-io-syntax
1441     (let ((*print-case* :downcase)
1442 heller 1.185 (*print-readably* nil)
1443 heller 1.31 (*print-pretty* nil)
1444     (*package* *swank-io-package*))
1445     (prin1-to-string object))))
1446 dbarlow 1.28
1447 heller 1.112 (defun force-user-output ()
1448 heller 1.551 (force-output (connection.user-io *emacs-connection*)))
1449 heller 1.112
1450     (defun clear-user-input ()
1451     (clear-input (connection.user-input *emacs-connection*)))
1452 lgorrie 1.62
1453 lgorrie 1.91 (defvar *read-input-catch-tag* 0)
1454    
1455 heller 1.232 (defun intern-catch-tag (tag)
1456     ;; fixnums aren't eq in ABCL, so we use intern to create tags
1457     (intern (format nil "~D" tag) :swank))
1458    
1459 heller 1.112 (defun read-user-input-from-emacs ()
1460 heller 1.281 (let ((tag (incf *read-input-catch-tag*)))
1461 heller 1.117 (force-output)
1462 heller 1.281 (send-to-emacs `(:read-string ,(current-thread) ,tag))
1463 lgorrie 1.90 (let ((ok nil))
1464 lgorrie 1.62 (unwind-protect
1465 heller 1.281 (prog1 (catch (intern-catch-tag tag)
1466 heller 1.112 (loop (read-from-emacs)))
1467 lgorrie 1.62 (setq ok t))
1468     (unless ok
1469 heller 1.281 (send-to-emacs `(:read-aborted ,(current-thread) ,tag)))))))
1470 mkoeppe 1.327
1471 heller 1.330 (defun y-or-n-p-in-emacs (format-string &rest arguments)
1472 mkoeppe 1.327 "Like y-or-n-p, but ask in the Emacs minibuffer."
1473     (let ((tag (incf *read-input-catch-tag*))
1474 heller 1.330 (question (apply #'format nil format-string arguments)))
1475 mkoeppe 1.327 (force-output)
1476     (send-to-emacs `(:y-or-n-p ,(current-thread) ,tag ,question))
1477 heller 1.330 (catch (intern-catch-tag tag)
1478     (loop (read-from-emacs)))))
1479 lgorrie 1.90
1480 lgorrie 1.62 (defslimefun take-input (tag input)
1481 heller 1.147 "Return the string INPUT to the continuation TAG."
1482 heller 1.232 (throw (intern-catch-tag tag) input))
1483 mbaringer 1.279
1484 mbaringer 1.346 (defun process-form-for-emacs (form)
1485     "Returns a string which emacs will read as equivalent to
1486     FORM. FORM can contain lists, strings, characters, symbols and
1487     numbers.
1488    
1489     Characters are converted emacs' ?<char> notaion, strings are left
1490     as they are (except for espacing any nested \" chars, numbers are
1491 alendvai 1.447 printed in base 10 and symbols are printed as their symbol-name
1492 mbaringer 1.346 converted to lower case."
1493     (etypecase form
1494     (string (format nil "~S" form))
1495     (cons (format nil "(~A . ~A)"
1496     (process-form-for-emacs (car form))
1497     (process-form-for-emacs (cdr form))))
1498     (character (format nil "?~C" form))
1499 alendvai 1.447 (symbol (concatenate 'string (when (eq (symbol-package form)
1500     #.(find-package "KEYWORD"))
1501     ":")
1502     (string-downcase (symbol-name form))))
1503 mbaringer 1.346 (number (let ((*print-base* 10))
1504     (princ-to-string form)))))
1505    
1506 heller 1.281 (defun eval-in-emacs (form &optional nowait)
1507     "Eval FORM in Emacs."
1508 mbaringer 1.346 (cond (nowait
1509     (send-to-emacs `(:eval-no-wait ,(process-form-for-emacs form))))
1510     (t
1511     (force-output)
1512     (let* ((tag (incf *read-input-catch-tag*))
1513     (value (catch (intern-catch-tag tag)
1514     (send-to-emacs
1515 heller 1.348 `(:eval ,(current-thread) ,tag
1516     ,(process-form-for-emacs form)))
1517 mbaringer 1.346 (loop (read-from-emacs)))))
1518     (destructure-case value
1519     ((:ok value) value)
1520     ((:abort) (abort)))))))
1521 heller 1.337
1522 mbaringer 1.414 (defvar *swank-wire-protocol-version* nil
1523 heller 1.418 "The version of the swank/slime communication protocol.")
1524 mbaringer 1.414
1525 heller 1.126 (defslimefun connection-info ()
1526 heller 1.343 "Return a key-value list of the form:
1527 heller 1.418 \(&key PID STYLE LISP-IMPLEMENTATION MACHINE FEATURES PACKAGE VERSION)
1528 heller 1.343 PID: is the process-id of Lisp process (or nil, depending on the STYLE)
1529     STYLE: the communication style
1530 heller 1.351 LISP-IMPLEMENTATION: a list (&key TYPE NAME VERSION)
1531 heller 1.343 FEATURES: a list of keywords
1532 mbaringer 1.413 PACKAGE: a list (&key NAME PROMPT)
1533 heller 1.418 VERSION: the protocol version"
1534 heller 1.260 (setq *slime-features* *features*)
1535 heller 1.343 `(:pid ,(getpid) :style ,(connection.communication-style *emacs-connection*)
1536     :lisp-implementation (:type ,(lisp-implementation-type)
1537 heller 1.350 :name ,(lisp-implementation-type-name)
1538 heller 1.343 :version ,(lisp-implementation-version))
1539     :machine (:instance ,(machine-instance)
1540     :type ,(machine-type)
1541     :version ,(machine-version))
1542     :features ,(features-for-emacs)
1543 heller 1.518 :modules ,*modules*
1544 heller 1.343 :package (:name ,(package-name *package*)
1545 mbaringer 1.413 :prompt ,(package-string-for-prompt *package*))
1546 heller 1.418 :version ,*swank-wire-protocol-version*))
1547 lgorrie 1.62
1548 heller 1.551 (defslimefun io-speed-test (&optional (n 1000) (m 1))
1549 heller 1.339 (let* ((s *standard-output*)
1550     (*trace-output* (make-broadcast-stream s *log-output*)))
1551 heller 1.337 (time (progn
1552     (dotimes (i n)
1553     (format s "~D abcdefghijklm~%" i)
1554     (when (zerop (mod n m))
1555 heller 1.551 (finish-output s)))
1556 heller 1.337 (finish-output s)
1557 heller 1.339 (when *emacs-connection*
1558     (eval-in-emacs '(message "done.")))))
1559     (terpri *trace-output*)
1560     (finish-output *trace-output*)
1561 heller 1.337 nil))
1562    
1563 lgorrie 1.62
1564     ;;;; Reading and printing
1565 dbarlow 1.28
1566 heller 1.207 (defmacro define-special (name doc)
1567     "Define a special variable NAME with doc string DOC.
1568 heller 1.232 This is like defvar, but NAME will not be initialized."
1569 heller 1.207 `(progn
1570     (defvar ,name)
1571 heller 1.240 (setf (documentation ',name 'variable) ,doc)))
1572 heller 1.207
1573     (define-special *buffer-package*
1574     "Package corresponding to slime-buffer-package.
1575 dbarlow 1.28
1576 heller 1.149 EVAL-FOR-EMACS binds *buffer-package*. Strings originating from a slime
1577 dbarlow 1.28 buffer are best read in this package. See also FROM-STRING and TO-STRING.")
1578    
1579 heller 1.207 (define-special *buffer-readtable*
1580     "Readtable associated with the current buffer")
1581 heller 1.189
1582     (defmacro with-buffer-syntax ((&rest _) &body body)
1583     "Execute BODY with appropriate *package* and *readtable* bindings.
1584    
1585     This should be used for code that is conceptionally executed in an
1586     Emacs buffer."
1587     (destructuring-bind () _
1588 heller 1.293 `(call-with-buffer-syntax (lambda () ,@body))))
1589    
1590     (defun call-with-buffer-syntax (fun)
1591     (let ((*package* *buffer-package*))
1592     ;; Don't shadow *readtable* unnecessarily because that prevents
1593     ;; the user from assigning to it.
1594     (if (eq *readtable* *buffer-readtable*)
1595     (call-with-syntax-hooks fun)
1596     (let ((*readtable* *buffer-readtable*))
1597     (call-with-syntax-hooks fun)))))
1598 heller 1.189
1599 heller 1.330 (defun to-string (object)
1600     "Write OBJECT in the *BUFFER-PACKAGE*.
1601 nsiivola 1.354 The result may not be readable. Handles problems with PRINT-OBJECT methods
1602     gracefully."
1603 heller 1.330 (with-buffer-syntax ()
1604     (let ((*print-readably* nil))
1605 nsiivola 1.354 (handler-case
1606     (prin1-to-string object)
1607     (error ()
1608     (with-output-to-string (s)
1609     (print-unreadable-object (object s :type t :identity t)
1610     (princ "<<error printing object>>" s))))))))
1611 heller 1.330
1612 dbarlow 1.28 (defun from-string (string)
1613     "Read string in the *BUFFER-PACKAGE*"
1614 heller 1.189 (with-buffer-syntax ()
1615     (let ((*read-suppress* nil))
1616     (read-from-string string))))
1617 lgorrie 1.60
1618 heller 1.245 ;; FIXME: deal with #\| etc. hard to do portably.
1619     (defun tokenize-symbol (string)
1620 mbaringer 1.467 "STRING is interpreted as the string representation of a symbol
1621     and is tokenized accordingly. The result is returned in three
1622     values: The package identifier part, the actual symbol identifier
1623     part, and a flag if the STRING represents a symbol that is
1624     internal to the package identifier part. (Notice that the flag is
1625     also true with an empty package identifier part, as the STRING is
1626     considered to represent a symbol internal to some current package.)"
1627 heller 1.245 (let ((package (let ((pos (position #\: string)))
1628     (if pos (subseq string 0 pos) nil)))
1629     (symbol (let ((pos (position #\: string :from-end t)))
1630     (if pos (subseq string (1+ pos)) string)))
1631 mbaringer 1.467 (internp (not (= (count #\: string) 1))))
1632 heller 1.245 (values symbol package internp)))
1633    
1634 mkoeppe 1.370 (defun tokenize-symbol-thoroughly (string)
1635 mbaringer 1.467 "This version of TOKENIZE-SYMBOL handles escape characters."
1636 mkoeppe 1.370 (let ((package nil)
1637     (token (make-array (length string) :element-type 'character
1638     :fill-pointer 0))
1639     (backslash nil)
1640     (vertical nil)
1641     (internp nil))
1642     (loop for char across string
1643     do (cond
1644     (backslash
1645     (vector-push-extend char token)
1646     (setq backslash nil))
1647     ((char= char #\\) ; Quotes next character, even within |...|
1648     (setq backslash t))
1649     ((char= char #\|)
1650     (setq vertical t))
1651     (vertical
1652     (vector-push-extend char token))
1653     ((char= char #\:)
1654     (if package
1655     (setq internp t)
1656     (setq package token
1657     token (make-array (length string)
1658     :element-type 'character
1659     :fill-pointer 0))))
1660     (t
1661     (vector-push-extend (casify-char char) token))))
1662 mbaringer 1.467 (values token package (or (not package) internp))))
1663 mkoeppe 1.370
1664 trittweiler 1.488 (defun untokenize-symbol (package-name internal-p symbol-name)
1665     "The inverse of TOKENIZE-SYMBOL.
1666    
1667     (untokenize-symbol \"quux\" nil \"foo\") ==> \"quux:foo\"
1668     (untokenize-symbol \"quux\" t \"foo\") ==> \"quux::foo\"
1669     (untokenize-symbol nil nil \"foo\") ==> \"foo\"
1670     "
1671 heller 1.507 (cond ((not package-name) symbol-name)
1672     (internal-p (cat package-name "::" symbol-name))
1673     (t (cat package-name ":" symbol-name))))
1674 trittweiler 1.488
1675 mkoeppe 1.370 (defun casify-char (char)
1676     "Convert CHAR accoring to readtable-case."
1677 heller 1.245 (ecase (readtable-case *readtable*)
1678 mkoeppe 1.370 (:preserve char)
1679     (:upcase (char-upcase char))
1680     (:downcase (char-downcase char))
1681     (:invert (if (upper-case-p char)
1682     (char-downcase char)
1683     (char-upcase char)))))
1684 heller 1.245
1685 heller 1.207 (defun parse-symbol (string &optional (package *package*))
1686 heller 1.189 "Find the symbol named STRING.
1687 heller 1.277 Return the symbol and a flag indicating whether the symbols was found."
1688 mkoeppe 1.370 (multiple-value-bind (sname pname) (tokenize-symbol-thoroughly string)
1689 heller 1.277 (let ((package (cond ((string= pname "") keyword-package)
1690 mkoeppe 1.370 (pname (find-package pname))
1691 heller 1.277 (t package))))
1692     (if package
1693 trittweiler 1.500 (multiple-value-bind (symbol flag) (find-symbol sname package)
1694     (values symbol flag sname package))
1695     (values nil nil nil nil)))))
1696 heller 1.189
1697 heller 1.207 (defun parse-symbol-or-lose (string &optional (package *package*))
1698     (multiple-value-bind (symbol status) (parse-symbol string package)
1699     (if status
1700     (values symbol status)
1701 heller 1.405 (error "Unknown symbol: ~A [in ~A]" string package))))
1702 heller 1.207
1703 heller 1.189 (defun parse-package (string)
1704     "Find the package named STRING.
1705     Return the package or nil."
1706 heller 1.517 ;; STRING comes usually from a (in-package STRING) form.
1707     (ignore-errors
1708     (find-package (let ((*package* *swank-io-package*))
1709     (read-from-string string)))))
1710 heller 1.190
1711 heller 1.458 (defun unparse-name (string)
1712     "Print the name STRING according to the current printer settings."
1713     ;; this is intended for package or symbol names
1714     (subseq (prin1-to-string (make-symbol string)) 2))
1715    
1716 heller 1.459 (defun guess-package (string)
1717     "Guess which package corresponds to STRING.
1718     Return nil if no package matches."
1719     (or (find-package string)
1720     (parse-package string)
1721     (if (find #\! string) ; for SBCL
1722     (guess-package (substitute #\- #\! string)))))
1723 dbarlow 1.28
1724 heller 1.191 (defvar *readtable-alist* (default-readtable-alist)
1725 heller 1.189 "An alist mapping package names to readtables.")
1726    
1727 heller 1.459 (defun guess-buffer-readtable (package-name)
1728     (let ((package (guess-package package-name)))
1729     (or (and package
1730     (cdr (assoc (package-name package) *readtable-alist*
1731     :test #'string=)))
1732     *readtable*)))
1733 heller 1.189
1734 lgorrie 1.62
1735 lgorrie 1.218 ;;;; Evaluation
1736    
1737 heller 1.278 (defvar *pending-continuations* '()
1738     "List of continuations for Emacs. (thread local)")
1739    
1740 lgorrie 1.218 (defun guess-buffer-package (string)
1741     "Return a package for STRING.
1742     Fall back to the the current if no such package exists."
1743 heller 1.459 (or (and string (guess-package string))
1744 lgorrie 1.218 *package*))
1745    
1746     (defun eval-for-emacs (form buffer-package id)
1747 mbaringer 1.466 "Bind *BUFFER-PACKAGE* to BUFFER-PACKAGE and evaluate FORM.
1748 lgorrie 1.218 Return the result to the continuation ID.
1749     Errors are trapped and invoke our debugger."
1750 heller 1.281 (call-with-debugger-hook
1751     #'swank-debugger-hook
1752     (lambda ()
1753 heller 1.508 (let (ok result)
1754 heller 1.281 (unwind-protect
1755     (let ((*buffer-package* (guess-buffer-package buffer-package))
1756     (*buffer-readtable* (guess-buffer-readtable buffer-package))
1757 heller 1.331 (*pending-continuations* (cons id *pending-continuations*)))
1758 heller 1.293 (check-type *buffer-package* package)
1759     (check-type *buffer-readtable* readtable)
1760 heller 1.353 ;; APPLY would be cleaner than EVAL.
1761     ;;(setq result (apply (car form) (cdr form)))
1762 heller 1.508 (setq result (eval form))
1763     (run-hook *pre-reply-hook*)
1764     (setq ok t))
1765 heller 1.281 (send-to-emacs `(:return ,(current-thread)
1766 mbaringer 1.399 ,(if ok
1767     `(:ok ,result)
1768 heller 1.508 `(:abort))
1769 heller 1.281 ,id)))))))
1770 lgorrie 1.218
1771 heller 1.337 (defvar *echo-area-prefix* "=> "
1772     "A prefix that `format-values-for-echo-area' should use.")
1773    
1774 lgorrie 1.218 (defun format-values-for-echo-area (values)
1775     (with-buffer-syntax ()
1776     (let ((*print-readably* nil))
1777 heller 1.242 (cond ((null values) "; No value")
1778 heller 1.525 ((and (integerp (car values)) (null (cdr values)))
1779 heller 1.242 (let ((i (car values)))
1780 heller 1.337 (format nil "~A~D (#x~X, #o~O, #b~B)"
1781     *echo-area-prefix* i i i i)))
1782 heller 1.511 (t (format nil "~a~{~S~^, ~}" *echo-area-prefix* values))))))
1783 lgorrie 1.218
1784     (defslimefun interactive-eval (string)
1785 heller 1.331 (with-buffer-syntax ()
1786     (let ((values (multiple-value-list (eval (from-string string)))))
1787     (fresh-line)
1788 heller 1.339 (finish-output)
1789 heller 1.332 (format-values-for-echo-area values))))
1790 lgorrie 1.218
1791 heller 1.278 (defslimefun eval-and-grab-output (string)
1792     (with-buffer-syntax ()
1793     (let* ((s (make-string-output-stream))
1794     (*standard-output* s)
1795 heller 1.293 (values (multiple-value-list (eval (from-string string)))))
1796 heller 1.278 (list (get-output-stream-string s)
1797     (format nil "~{~S~^~%~}" values)))))
1798    
1799 heller 1.503 (defun eval-region (string)
1800     "Evaluate STRING.
1801     Return the results of the last form as a list and as secondary value the
1802     last form."
1803     (with-input-from-string (stream string)
1804     (let (- values)
1805     (loop
1806     (let ((form (read stream nil stream)))
1807     (when (eq form stream)
1808     (return (values values -)))
1809     (setq - form)
1810     (setq values (multiple-value-list (eval form)))
1811     (finish-output))))))
1812 lgorrie 1.218
1813     (defslimefun interactive-eval-region (string)
1814     (with-buffer-syntax ()
1815     (format-values-for-echo-area (eval-region string))))
1816    
1817     (defslimefun re-evaluate-defvar (form)
1818     (with-buffer-syntax ()
1819     (let ((form (read-from-string form)))
1820     (destructuring-bind (dv name &optional value doc) form
1821     (declare (ignore value doc))
1822     (assert (eq dv 'defvar))
1823     (makunbound name)
1824     (prin1-to-string (eval form))))))
1825    
1826 heller 1.288 (defvar *swank-pprint-bindings*
1827     `((*print-pretty* . t)
1828     (*print-level* . nil)
1829     (*print-length* . nil)
1830     (*print-circle* . t)
1831     (*print-gensym* . t)
1832     (*print-readably* . nil))
1833     "A list of variables bindings during pretty printing.
1834     Used by pprint-eval.")
1835    
1836 lgorrie 1.218 (defun swank-pprint (list)
1837     "Bind some printer variables and pretty print each object in LIST."
1838     (with-buffer-syntax ()
1839 heller 1.288 (with-bindings *swank-pprint-bindings*
1840     (cond ((null list) "; No value")
1841     (t (with-output-to-string (*standard-output*)
1842     (dolist (o list)
1843     (pprint o)
1844     (terpri))))))))
1845 heller 1.250
1846 lgorrie 1.218 (defslimefun pprint-eval (string)
1847     (with-buffer-syntax ()
1848     (swank-pprint (multiple-value-list (eval (read-from-string string))))))
1849    
1850 heller 1.459 (defslimefun set-package (name)
1851     "Set *package* to the package named NAME.
1852     Return the full package-name and the string to use in the prompt."
1853     (let ((p (guess-package name)))
1854     (assert (packagep p))
1855 heller 1.458 (setq *package* p)
1856 lgorrie 1.218 (list (package-name p) (package-string-for-prompt p))))
1857    
1858 heller 1.503 ;;;;; Listener eval
1859    
1860     (defvar *listener-eval-function* 'repl-eval)
1861 mkoeppe 1.417
1862 lgorrie 1.218 (defslimefun listener-eval (string)
1863 heller 1.503 (funcall *listener-eval-function* string))
1864    
1865     (defvar *send-repl-results-function* 'send-repl-results-to-emacs)
1866    
1867     (defun repl-eval (string)
1868 lgorrie 1.218 (clear-user-input)
1869     (with-buffer-syntax ()
1870 heller 1.503 (track-package
1871     (lambda ()
1872     (multiple-value-bind (values last-form) (eval-region string)
1873     (setq *** ** ** * * (car values)
1874     /// // // / / values
1875     +++ ++ ++ + + last-form)
1876     (funcall *send-repl-results-function* values)))))
1877 mkoeppe 1.444 nil)
1878 lgorrie 1.218
1879 heller 1.503 (defun track-package (fun)
1880     (let ((p *package*))
1881     (unwind-protect (funcall fun)
1882     (unless (eq *package* p)
1883     (send-to-emacs (list :new-package (package-name *package*)
1884     (package-string-for-prompt *package*)))))))
1885    
1886     (defun send-repl-results-to-emacs (values)
1887 heller 1.506 (fresh-line)
1888     (finish-output)
1889 heller 1.503 (if (null values)
1890     (send-to-emacs `(:write-string "; No value" :repl-result))
1891     (dolist (v values)
1892     (send-to-emacs `(:write-string ,(cat (prin1-to-string v) #\newline)
1893     :repl-result)))))
1894    
1895     (defun cat (&rest strings)
1896     "Concatenate all arguments and make the result a string."
1897     (with-output-to-string (out)
1898     (dolist (s strings)
1899     (etypecase s
1900     (string (write-string s out))
1901     (character (write-char s out))))))
1902    
1903     (defun package-string-for-prompt (package)
1904     "Return the shortest nickname (or canonical name) of PACKAGE."
1905     (unparse-name
1906     (or (canonical-package-nickname package)
1907     (auto-abbreviated-package-name package)
1908     (shortest-package-nickname package))))
1909    
1910     (defun canonical-package-nickname (package)
1911     "Return the canonical package nickname, if any, of PACKAGE."
1912     (let ((name (cdr (assoc (package-name package) *canonical-package-nicknames*
1913     :test #'string=))))
1914     (and name (string name))))
1915    
1916     (defun auto-abbreviated-package-name (package)
1917     "Return an abbreviated 'name' for PACKAGE.
1918    
1919     N.B. this is not an actual package name or nickname."
1920     (when *auto-abbreviate-dotted-packages*
1921     (let ((last-dot (position #\. (package-name package) :from-end t)))
1922     (when last-dot (subseq (package-name package) (1+ last-dot))))))
1923    
1924     (defun shortest-package-nickname (package)
1925     "Return the shortest nickname (or canonical name) of PACKAGE."
1926     (loop for name in (cons (package-name package) (package-nicknames package))
1927     for shortest = name then (if (< (length name) (length shortest))
1928     name
1929     shortest)
1930     finally (return shortest)))
1931    
1932 lgorrie 1.218 (defslimefun ed-in-emacs (&optional what)
1933     "Edit WHAT in Emacs.
1934    
1935     WHAT can be:
1936 crhodes 1.307 A pathname or a string,
1937     A list (PATHNAME-OR-STRING LINE [COLUMN]),
1938 crhodes 1.371 A function name (symbol or cons),
1939 crhodes 1.307 NIL.
1940    
1941     Returns true if it actually called emacs, or NIL if not."
1942     (flet ((pathname-or-string-p (thing)
1943 heller 1.536 (or (pathnamep thing) (typep thing 'string)))
1944     (canonicalize-filename (filename)
1945     (namestring (or (probe-file filename) filename))))
1946 crhodes 1.307 (let ((target
1947     (cond ((and (listp what) (pathname-or-string-p (first what)))
1948     (cons (canonicalize-filename (car what)) (cdr what)))
1949     ((pathname-or-string-p what)
1950     (canonicalize-filename what))
1951     ((symbolp what) what)
1952 crhodes 1.371 ((consp what) what)
1953 crhodes 1.307 (t (return-from ed-in-emacs nil)))))
1954 crhodes 1.371 (cond
1955     (*emacs-connection* (send-oob-to-emacs `(:ed ,target)))
1956     ((default-connection)
1957     (with-connection ((default-connection))
1958     (send-oob-to-emacs `(:ed ,target))))
1959     (t nil)))))
1960 lgorrie 1.218
1961 nsiivola 1.426 (defslimefun inspect-in-emacs (what)
1962     "Inspect WHAT in Emacs."
1963     (flet ((send-it ()
1964     (with-buffer-syntax ()
1965     (reset-inspector)
1966     (send-oob-to-emacs `(:inspect ,(inspect-object what))))))
1967     (cond
1968     (*emacs-connection*
1969     (send-it))
1970     ((default-connection)
1971     (with-connection ((default-connection))
1972 alendvai 1.438 (send-it))))
1973     what))
1974 nsiivola 1.426
1975 lgorrie 1.286 (defslimefun value-for-editing (form)
1976     "Return a readable value of FORM for editing in Emacs.
1977     FORM is expected, but not required, to be SETF'able."
1978     ;; FIXME: Can we check FORM for setfability? -luke (12/Mar/2005)
1979 heller 1.288 (with-buffer-syntax ()
1980     (prin1-to-string (eval (read-from-string form)))))
1981 lgorrie 1.286
1982     (defslimefun commit-edited-value (form value)
1983     "Set the value of a setf'able FORM to VALUE.
1984     FORM and VALUE are both strings from Emacs."
1985 heller 1.289 (with-buffer-syntax ()
1986 heller 1.330 (eval `(setf ,(read-from-string form)
1987     ,(read-from-string (concatenate 'string "`" value))))
1988 heller 1.289 t))
1989 lgorrie 1.286
1990 heller 1.330 (defun background-message (format-string &rest args)
1991     "Display a message in Emacs' echo area.
1992    
1993     Use this function for informative messages only. The message may even
1994     be dropped, if we are too busy with other things."
1995     (when *emacs-connection*
1996     (send-to-emacs `(:background-message
1997     ,(apply #'format nil format-string args)))))
1998    
1999 lgorrie 1.218
2000 lgorrie 1.62 ;;;; Debugger
2001 heller 1.47
2002 heller 1.38 (defun swank-debugger-hook (condition hook)
2003 lgorrie 1.177 "Debugger function for binding *DEBUGGER-HOOK*.
2004 lgorrie 1.62 Sends a message to Emacs declaring that the debugger has been entered,
2005     then waits to handle further requests from Emacs. Eventually returns
2006     after Emacs causes a restart to be invoked."
2007 heller 1.67 (declare (ignore hook))
2008 heller 1.291 (cond (*emacs-connection*
2009     (debug-in-emacs condition))
2010     ((default-connection)
2011     (with-connection ((default-connection))
2012     (debug-in-emacs condition)))))
2013 lgorrie 1.223
2014     (defvar *global-debugger* t
2015     "Non-nil means the Swank debugger hook will be installed globally.")
2016    
2017     (add-hook *new-connection-hook* 'install-debugger)
2018     (defun install-debugger (connection)
2019     (declare (ignore connection))
2020     (when *global-debugger*
2021 heller 1.348 (install-debugger-globally #'swank-debugger-hook)))
2022 lgorrie 1.157
2023 lgorrie 1.212 ;;;;; Debugger loop
2024     ;;;
2025     ;;; These variables are dynamically bound during debugging.
2026     ;;;
2027     (defvar *swank-debugger-condition* nil
2028     "The condition being debugged.")
2029    
2030     (defvar *sldb-level* 0
2031     "The current level of recursive debugging.")
2032    
2033     (defvar *sldb-initial-frames* 20
2034     "The initial number of backtrace frames to send to Emacs.")
2035    
2036     (defvar *sldb-restarts* nil
2037     "The list of currenlty active restarts.")
2038    
2039 heller 1.256 (defvar *sldb-stepping-p* nil
2040 jsnellman 1.400 "True during execution of a step command.")
2041 heller 1.256
2042 lgorrie 1.157 (defun debug-in-emacs (condition)
2043 heller 1.38 (let ((*swank-debugger-condition* condition)
2044 mbaringer 1.470 (*sldb-restarts* (compute-sane-restarts condition))
2045 heller 1.107 (*package* (or (and (boundp '*buffer-package*)
2046     (symbol-value '*buffer-package*))
2047 heller 1.112 *package*))
2048     (*sldb-level* (1+ *sldb-level*))
2049 heller 1.256 (*sldb-stepping-p* nil)
2050 heller 1.250 (*swank-state-stack* (cons :swank-debugger-hook *swank-state-stack*)))
2051 lgorrie 1.157 (force-user-output)
2052 alendvai 1.435 (call-with-debugging-environment
2053 mbaringer 1.470 (lambda ()
2054 heller 1.453 (with-bindings *sldb-printer-bindings*
2055     (sldb-loop *sldb-level*))))))
2056 lgorrie 1.80
2057 lgorrie 1.62 (defun sldb-loop (level)
2058 heller 1.119 (unwind-protect
2059     (catch 'sldb-enter-default-debugger
2060 mbaringer 1.470 (send-to-emacs
2061 heller 1.291 (list* :debug (current-thread) level
2062 heller 1.119 (debugger-info-for-emacs 0 *sldb-initial-frames*)))
2063 heller 1.117 (loop (catch 'sldb-loop-catcher
2064     (with-simple-restart (abort "Return to sldb level ~D." level)
2065     (send-to-emacs (list :debug-activate (current-thread)
2066 heller 1.291 level))
2067 heller 1.117 (handler-bind ((sldb-condition #'handle-sldb-condition))
2068 heller 1.119 (read-from-emacs))))))
2069 heller 1.291 (send-to-emacs `(:debug-return
2070 heller 1.256 ,(current-thread) ,level ,*sldb-stepping-p*))))
2071 heller 1.117
2072 lgorrie 1.62 (defun handle-sldb-condition (condition)
2073     "Handle an internal debugger condition.
2074     Rather than recursively debug the debugger (a dangerous idea!), these
2075     conditions are simply reported."
2076     (let ((real-condition (original-condition condition)))
2077 heller 1.115 (send-to-emacs `(:debug-condition ,(current-thread)
2078 heller 1.250 ,(princ-to-string real-condition))))
2079 lgorrie 1.62 (throw 'sldb-loop-catcher nil))
2080    
2081 mbaringer 1.524 (defvar *sldb-condition-printer* #'format-sldb-condition
2082     "Function called to print a condition to an SLDB buffer.")
2083    
2084 heller 1.86 (defun safe-condition-message (condition)
2085     "Safely print condition to a string, handling any errors during
2086     printing."
2087 heller 1.516 (let ((*print-pretty* t) (*print-right-margin* 65))
2088 heller 1.147 (handler-case
2089 mbaringer 1.524 (funcall *sldb-condition-printer* condition)
2090 heller 1.147 (error (cond)
2091     ;; Beware of recursive errors in printing, so only use the condition
2092     ;; if it is printable itself:
2093     (format nil "Unable to display error condition~@[: ~A~]"
2094     (ignore-errors (princ-to-string cond)))))))
2095 heller 1.86
2096     (defun debugger-condition-for-emacs ()
2097     (list (safe-condition-message *swank-debugger-condition*)
2098     (format nil " [Condition of type ~S]"
2099 lgorrie 1.188 (type-of *swank-debugger-condition*))
2100 heller 1.240 (condition-extras *swank-debugger-condition*)))
2101 heller 1.86
2102 heller 1.138 (defun format-restarts-for-emacs ()
2103     "Return a list of restarts for *swank-debugger-condition* in a
2104     format suitable for Emacs."
2105 alendvai 1.437 (let ((*print-right-margin* most-positive-fixnum))
2106     (loop for restart in *sldb-restarts*
2107     collect (list (princ-to-string (restart-name restart))
2108     (princ-to-string restart)))))
2109 heller 1.138
2110 heller 1.86
2111 lgorrie 1.212 ;;;;; SLDB entry points
2112    
2113     (defslimefun sldb-break-with-default-debugger ()
2114     "Invoke the default debugger by returning from our debugger-loop."
2115     (throw 'sldb-enter-default-debugger nil))
2116    
2117 heller 1.138 (defslimefun backtrace (start end)
2118 heller 1.147 "Return a list ((I FRAME) ...) of frames from START to END.
2119     I is an integer describing and FRAME a string."
2120 heller 1.453 (loop for frame in (compute-backtrace start end)
2121     for i from start
2122     collect (list i (with-output-to-string (stream)
2123 heller 1.520 (handler-case
2124