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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.541 - (hide annotations)
Thu Mar 27 11:46:41 2008 UTC (6 years ago) by heller
Branch: MAIN
Changes since 1.540: +4 -2 lines
* swank-loader.lisp (load-swank): Call swank::before-init.

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