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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.731 - (hide annotations)
Fri Oct 8 09:03:24 2010 UTC (3 years, 6 months ago) by crhodes
Branch: MAIN
Changes since 1.730: +10 -9 lines
add richer location information to the position arg in compile-string-for-emacs

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