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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.704 - (hide annotations)
Thu Mar 18 18:24:25 2010 UTC (4 years, 1 month ago) by trittweiler
Branch: MAIN
Changes since 1.703: +19 -46 lines
	Remove attach-gdb restart. Instead add SLDB shortcut `A'.

	* slime.el (slime-dispatch-event): Remove :gdb-attach.
	(slime-attach-gdb): Changed API. Takes connection not pid now and
	lightweight &optional arg. If not lightweight, get the default gdb
	config from the inferior Lisp.
	(sldb-break-with-system-debugger): New command, bound to `A' in
	sldb. Called this way to mimick
	`sldb-break-with-default-debugger', and because it may make sense
	to go beyond gdb in future, e.g. to invoke the Java Debugger for
	ABCL.

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