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

Contents of /slime/swank.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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