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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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