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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.536 - (hide annotations)
Sun Feb 24 16:49:49 2008 UTC (6 years, 1 month ago) by heller
Branch: MAIN
Changes since 1.535: +3 -4 lines
Allow ED-IN-EMACS to edit new files.

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