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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.589 - (hide annotations)
Mon Sep 15 10:41:03 2008 UTC (5 years, 7 months ago) by heller
Branch: MAIN
Changes since 1.588: +27 -17 lines
* swank.lisp (sldb-loop): Send a :sldb-return event to ourselfes
to inform the debug session at the lower level.
(wait-for-event): Drop the report-interrupt argument.  No longer
needed.
(event-match-p): Add an OR pattern operator.  Used to wait for
different events simultaneously.

(read-packet): Use peek-char to detect EOF. read-sequence wouldn't
work.

* slime.el (slime-test-interrupt-in-debugger): Call sldb-quit and
sldb-continue in the right buffer.

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