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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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